perm filename EDIT.PAS[AL,HE] blob
sn#738209 filedate 1984-01-15 generic text, type C, neo UTF8
COMMENT ⊗ VALID 00071 PAGES
C REC PAGE DESCRIPTION
C00001 00001
C00009 00002 (*$E+ Routines to print out an AL statement given the internal format *)
C00013 00003 (* datatype definitions *)
C00016 00004 (* statement definitions *)
C00020 00005 (* auxiliary definitions: variable, etc. *)
C00022 00006 (* definition of the ubiquitous NODE record *)
C00029 00007 (* records for parser: ident, token, resword *)
C00033 00008 (* process descriptor blocks & environment record definitions *)
C00037 00009 (* print related records: *)
C00038 00010 (* global variables *)
C00042 00011 (* external routines *)
C00048 00012 (* aux routines: GetAChar,out1Line,clearLine,appendEnd,makeOuterBlock *)
C00052 00013 (* lookup routines: upperCase,eqStrng,hash,resLookup,idLookup,freeIds,findResword *)
C00057 00014 (* routine to make reserved words: initReswords *)
C00072 00015 (* routine to make predeclared identifiers & constants: initIdents *)
C00093 00016 (* allocation routines: getLine, relLine *)
C00098 00017 (* expression/line editor: exprEditor *)
C00116 00018 (* page printer routines: ppGlitch,ppChar,ppOutNow,ppLine,pp5,pp10(L),pp20(L),ppInt,ppReal,ppStrng,ppDelChar,ppFlush *)
C00123 00019 (* aux routines: makeNVar, makeUVar, varLookup, flushVar, makeNewVar *)
C00132 00020 (* basic read routines: readPPLine, readLine & errprnt *)
C00142 00021 (* getToken *)
C00164 00022 (* initialization routines: initEditor & initOuterBlock *)
C00168 00023 (* print routines: putChar, put5, put10, putLine *)
C00172 00024 (* aux print routines: putReal, putInt, putVec, putTrans, putStrng, putTlist *)
C00178 00025 (* expression related routines: getExprLength & putExpr *)
C00187 00026 (* cursorStack routines: pushStmnt, pushNode, ... *)
C00189 00027 (* putStmnt: aux routines: newline, outExpr, putVars, putClause, codeLength *)
C00203 00028 (* putStmnt: main body *)
C00226 00029 (* cursor moving routines: nextStmnt, lastStmnt, parentStmnt *)
C00244 00030 (* setUpStmnt,bannerLine,borderLines,redrawDisplay,adjustDisplay *)
C00249 00031 (* displayLines routine *)
C00258 00032 (* routines to shift display: deleteLines, insertLines, reFormatStmnt *)
C00273 00033 (* aux routines for parsing exprs: matchdim,getdim,dimCheck,getDelim,getDo,ppDtype *)
C00281 00034 (* aux routines for parsing exprs: defNode,getDtype,checkarg,copyExpr *)
C00287 00035 (* aux routines for parsing expressions(cont): getArgs *)
C00301 00036 (* function to parse expressions: exprParse *)
C00321 00037 (* auxiliary expression mungers: relExpr & evalOrder *)
C00330 00038 (* aux routine to set up evaluation order for motions: moveOrder *)
C00346 00039 (* assignParse *)
C00354 00040 (* forParse *)
C00358 00041 (* affixParse & unfixParse *)
C00366 00042 (* enableParse *)
C00369 00043 (* getBlkId, idGet & plistParse *)
C00378 00044 (* labelParse & clabelParse *)
C00381 00045 (* aux routines: declarationp, getDeclarations & addNewDeclarations *)
C00403 00046 (* aux routine: reParse *)
C00424 00047 (* varParse & procParse *)
C00441 00048 (* aux functions for motion clauses: thenCode, getcsys & clauseParse *)
C00460 00049 (* cmonParse *)
C00467 00050 (* moveParse *)
C00473 00051 (* mClauseParse *)
C00480 00052 (* stopParse *)
C00483 00053 (* returnParse *)
C00485 00054 (* waitParse & wristParse *)
C00490 00055 (* armMagicParse *)
C00494 00056 (* editStmnt: aux routines: echarDo, goEd, editExpr, downLine *)
C00497 00057 (* editStmnt: main body *)
C00513 00058 (* addStmnt: aux routines: getEmptyStmnt,flushSemi,descend,elseTest,restoreCursor,setUpNewStmnt,viaOk *)
C00521 00059 (* addStmnt: aux routines: addNewSt,addNode,addNewEnv,addCmon & addDeclSt *)
C00534 00060 (* addStmnt: main body *)
C00565 00061 (* delStmnt *)
C00584 00062 (* bracketStmnt *)
C00588 00063 (* aux routines: mark, unmark & gotoMark *)
C00591 00064 (* aux routine: setPPSize, flushOldEnvironments, saveOutermostEnv *)
C00597 00065 (* aux routine: fileParse, writeProg, readProg *)
C00606 00066 (* aux routine: varDefine *)
C00611 00067 (* routines for breakpoints: setBpt,clrBpt,clrAllBpts,setTBpt,stepStmnt,clrTBpts *)
C00620 00068 (* debugging routines: dGetPdb,dfreePdb,getPCline,runStmnt,executeStmnt,pevalExpr,goStmnt *)
C00633 00069 (* debugging routines: tracePdb, trace, setECurInt *)
C00638 00070 (* edit: aux routines: getCChar,getEcmd,doSetCmd,collectStmnt,atStmnt,doAtCmd *)
C00652 00071 (* main editing routine: edit *)
C00674 ENDMK
C⊗;
(*$E+ Routines to print out an AL statement given the internal format *)
(*$S3000 use a large codesize *)
program edit;
const
version = 10; (* 10 for simulation version, 11 for real thing *)
maxLines = 40;
maxPPLines = 30;
maxBpts = 25;
maxTBpts = 20; (* max could be exceeded by huge case stmnt *)
listinglength = 6000; (* Length of Listingarray *)
(* Control character definitions and others *)
ctlA = 01; (* Control-A *)
ctlB = 02;
ctlC = 03;
ctlD = 04;
ctlE = 05;
ctlF = 06;
ctlG = 07;
ctlH = 08;
ctlI = 09;
ctlJ = 10;
ctlK = 11;
ctlL = 12;
ctlM = 13;
ctlN = 14;
ctlO = 15;
ctlP = 16;
ctlQ = 17;
ctlR = 18;
ctlS = 19;
ctlT = 20;
ctlU = 21;
ctlV = 22;
ctlW = 23;
ctlX = 24;
ctlY = 25;
ctlZ = 26;
ESC = 27; (* Escape *)
ctlBslash = 28; (* Control - backslash ↑\ *)
VT = ctlK; (* Vertical tab *)
FF = ctlL; (* Form feed *)
CR = ctlM; (* Carriage return *)
LF = ctlJ; (* Line feed *)
TAB = ctlI; (* Tab *)
smallA = 97; (* Lowercase a (sail pascal converts all input to upper case) *)
smallC = 99; (* Lowercase c *)
smallZ = 122; (* Lowercase z *)
undline = 95; (* Underline _ *)
vbar = 124; (* Vertical bar | *)
lbrace = 123; (* Left brace (curly bracket) *)
rbrace = 126; (* and right brace *) (* *** SAIL <> ascii *** *)
deletekey = 127; (* Delete key code *)
sailundline = 24; (* Underline, only for SAIL *)
sailbackarrow = 95; (* Back arrow (←), only for SAIL *)
type
(* random type declarations for OMSI/SAIL compatibility *)
(* ascii = char; *)
atext = packed file of ascii;
(* atext = text; *)
(* Here are all the pointer-type definitions. Since the various *)
(* records reference each other so much, we have to put them all here. *)
vectorp = ↑vector;
transp = ↑trans;
strngp = ↑strng;
eventp = ↑event;
framep = ↑frame;
statementp = ↑statement;
varidefp = ↑varidef;
nodep = ↑node;
identp = ↑ident;
tokenp = ↑token;
reswordp = ↑resword;
pdbp = ↑pdb;
envheaderp = ↑envheader;
enventryp = ↑enventry;
environp = ↑environment;
cmoncbp = ↑cmoncb;
linerecp = ↑linerec;
(* datatype definitions *)
datatypes = (pconstype, varitype, svaltype, vectype, rottype, transtype,
frametype, eventtype, strngtype, labeltype, proctype, arraytype,
reftype, valtype, cmontype, nulltype, undeftype,
dimensiontype, mactype, macargtype, freevartype);
scalar = real;
vector = record refcnt: integer; val: array [1..3] of real end;
trans = record refcnt: integer; val: array [1..3,1..4] of real end;
cstring = packed array [1..10] of ascii;
c4str = packed array [1..4] of ascii;
c5str = packed array [1..5] of ascii;
c20str = packed array [1..20] of ascii;
linestr = packed array [1..130] of ascii;
strng = record
next: strngp;
ch: cstring;
end;
event = record
next: eventp; (* all events are on one big list *)
count: integer;
waitlist: pdbp;
end;
frame = record
vari: varidefp; (* back pointer to variable name & info *)
calcs: nodep; (* affixment info *)
case ftype: boolean of (* frame = true, device = false *)
true: (valid: integer; val, fdepr: transp; dcntr: integer; dev: framep);
false: (mech: integer; case sdev: boolean of
true: (sdest: real); false: (tdest,appr,depr: transp));
(* sdev = true for scalar devices, false for frames *)
end;
byte = 0..255; (* doesn't really belong here, but... *)
(* statement definitions *)
stmntypes = (progtype, blocktype, coblocktype, endtype, coendtype,
fortype, iftype, whiletype, untiltype, casetype,
calltype, returntype,
printtype, prompttype, pausetype, aborttype, assigntype,
signaltype, waittype, enabletype, disabletype, cmtype,
affixtype, unfixtype,
movetype,jtmovetype,operatetype,opentype,closetype,centertype,
floattype, stoptype, retrytype,
requiretype, definetype, macrotype, commenttype, dimdeftype,
setbasetype, wristtype, saytype, declaretype, emptytype,
evaltype, armmagictype);
(* more??? *)
statement = packed record
next, last: statementp;
stlab: varidefp;
exprs: nodep; (* any expressions used by this statement *)
nlines: integer;
bpt,bad: boolean;
case stype: stmntypes of
progtype: (pcode: statementp; errors: integer);
blocktype,
declaretype,
endtype,
coendtype: (bcode, bparent: statementp; blkid: identp;
level, numvars: 0..255; variables: varidefp);
coblocktype: (threads: nodep; nthreads: integer; cblkid: identp);
fortype: (forvar, initial, step, final: nodep; fbody: statementp);
whiletype,
untiltype: (cond: nodep; body: statementp);
casetype: (index: nodep; range, ncases: integer; caselist: nodep);
iftype: (icond: nodep; thn, els: statementp);
pausetype: (ptime: nodep);
prompttype,
printtype,
aborttype,
saytype: (plist: nodep; debugLev: integer);
returntype: (retval, rproc: nodep);
evaltype,
calltype,
assigntype: (what, aval: nodep);
affixtype,
unfixtype: (frame1, frame2, byvar, atexp: nodep; rigid: boolean);
signaltype,
waittype: (event: nodep);
movetype,
jtmovetype,
operatetype,
opentype,
closetype,
centertype,
floattype,
setbasetype,
stoptype: (cf, clauses: nodep);
retrytype: (rcode, rparent: statementp; olevel: integer);
wristtype: (arm, ff, fvec, tvec: nodep; csys: boolean);
cmtype: (oncond: nodep; conclusion: statementp;
deferCm, exprCm: boolean; cdef: varidefp);
enabletype,
disabletype: (cmonlab: varidefp);
requiretype: (rfil: boolean; rfils: strngp; rfilen: integer);
definetype: (macname,mpars: varidefp; macdef: tokenp);
commenttype: (len: integer; str: strngp; cbody: statementp);
dimdeftype: (dimname: varidefp; dimexpr: nodep);
armmagictype: (cmdnum,dev,iargs,oargs: nodep);
end;
(* auxiliary definitions: variable, etc. *)
varidef = packed record
next,dnext: varidefp;
name: identp;
level: 0..255; (* environment level *)
offset: 0..255; (* environment offset *)
dtype: varidefp; (* to hold the dimension info *)
tbits: 0..15; (* special type bits: array = 1, proc = 2, ref = 4 & ? *)
dbits: 0..15; (* for use by debugger/interpreter *)
case vtype: datatypes of
arraytype: (a: nodep);
proctype: (p: nodep);
labeltype,
cmontype: (s: statementp);
mactype: (mdef: statementp);
macargtype: (marg: tokenp);
pconstype: (c: nodep);
dimensiontype: (dim: nodep);
end;
(* definition of the ubiquitous NODE record *)
nodetypes = (exprnode, leafnode, listnode, clistnode, colistnode, forvalnode,
deprnode, viaptnode, apprnode, destnode, byptnode, durnode,
sfacnode, wobblenode, swtnode, nullingnode, wristnode, cwnode,
arrivalnode, departingnode,
ffnode, forcenode, stiffnode, gathernode, cmonnode, errornode,
calcnode, arraydefnode, bnddefnode, bndvalnode,
waitlistnode, procdefnode, tlistnode, dimnode, commentnode,
linearnode, elbownode, shouldernode, flipnode, wrtnode,
loadnode,velocitynode);
exprtypes = ( svalop, (* scalar operators *)
sltop, sleop, seqop, sgeop, sgtop, sneop, (* relations *)
notop, orop, xorop, andop, eqvop, (* logical *)
saddop, ssubop, smulop, sdivop, snegop, sabsop, (* scalar ops *)
sexpop, maxop, minop, intop, idivop, modop,
sqrtop, logop, expop, timeop, (* functions *)
sinop, cosop, tanop, asinop, acosop, atan2op, (* trig *)
vdotop, vmagnop, tmagnop,
vecop, (* vector operators *)
vmakeop, unitvop, vaddop, vsubop, crossvop, vnegop,
svmulop, vsmulop, vsdivop, tvmulop, wrtop,
tposop, taxisop,
transop, (* trans operators *)
tmakeop, torientop, ttmulop, tvaddop, tvsubop, tinvrtop,
vsaxwrop, constrop, ftofop, deproachop, fmakeop, vmkfrcop,
ioop, (* i/o operators *)
queryop, inscalarop,
specop, (* special operators *)
arefop, callop, grinchop, macroop, vmop, adcop, dacop, jointop,
badop,
addop, subop, negop, mulop, divop, absop); (* for parsing *)
leaftypes = pconstype..strngtype;
reltypes = sltop..sgtop;
forcetypes = (force,absforce,torque,abstorque,angvelocity);
node = record
next: nodep;
case ntype: nodetypes of
exprnode: (op: exprtypes; arg1, arg2, arg3: nodep; elength: integer);
leafnode: (case ltype: leaftypes of
varitype: (vari: varidefp; vid: identp);
pconstype: (cname: varidefp; pcval: nodep);
svaltype: (s: scalar; wid: integer);
vectype: (v: vectorp);
transtype: (t: transp);
strngtype: (length: integer; str: strngp) ); (* also used by commentnodes *)
listnode: (lval: nodep);
clistnode: (cval: integer; stmnt: statementp; clast: nodep);
colistnode: (prev: nodep; cstmnt: statementp);
forvalnode: (fvar: enventryp; fstep: scalar; fstmnt: statementp);
arrivalnode:(evar: varidefp);
wrtnode,
deprnode,
apprnode,
destnode: (loc: nodep; code: statementp);
byptnode,
viaptnode: (vlist: boolean; via,vclauses: nodep; vcode: statementp);
durnode: (durrel: reltypes; durval: nodep);
velocitynode,
sfacnode,
wobblenode,
swtnode: (clval: nodep);
nullingnode, (* true = nonulling *)
wristnode, (* = don't zero force wrist *)
cwnode, (* = counter_clockwise *)
elbownode, (* = elbow up *)
shouldernode, (* = right shoulder *)
flipnode, (* = don't flip wrist *)
linearnode: (notp: boolean); (* = linear motion *)
ffnode: (ff,cf: nodep; csys, pdef: boolean); (* true = world, false = hand *)
loadnode: (loadval,loadvec: nodep; lcsys: boolean); (* lcsys = csys above *)
forcenode: (ftype: forcetypes; frel: reltypes; fval, fvec, fframe: nodep);
stiffnode: (fv, mv, cocff: nodep);
gathernode: (gbits: integer);
cmonnode: (cmon: statementp; errhandlerp: boolean);
errornode: (eexpr: nodep);
calcnode: (rigid, frame1: boolean; other: framep; case tvarp: boolean of
false: (tval: transp); true: (tvar: enventryp) );
arraydefnode: (numdims: 1..10; bounds: nodep; combnds: boolean);
bnddefnode: (lower, upper: nodep);
bndvalnode: (lb, ub, mult: integer);
waitlistnode: (who: pdbp; when: integer);
procdefnode:(ptype: datatypes; level: 0..255;
pname, paramlist: varidefp; body: statementp);
tlistnode: (tok: tokenp);
dimnode: (time, distance, angle, dforce: integer);
end;
(* records for parser: ident, token, resword *)
ident = record
next: identp;
length: integer;
name: strngp;
predefined: varidefp;
end;
tokentypes = (reswdtype, identtype, constype, comnttype, delimtype, labeldeftype,
macpartype);
constypes = svaltype..strngtype;
reswdtypes = (stmnttype, filtype, clsetype, decltype, optype, edittype);
filtypes = (abouttype,alongtype,attype,bytype,defertype,dotype,elsetype,
errmodestype,fromtype,handtype,intype,nonrigidlytype,rigidlytype,
sourcefiletype,steptype,thentype,totype,untltype,viatype,
withtype,worldtype,zeroedtype,oftype,wheretype,nowaittype,
ontype,offtype,ppsizetype,collecttype,alltype,lextype,
notype,righttype,lefttype,uptype,downtype,motiontype);
clsetypes = (approachtype,arrivaltype,departuretype,departingtype,durationtype,
errortype,forcetype,forceframetype,forcewristtype,gathertype,
nildeproachtype,nullingtype,stiffnesstype,
torquetype,velocitytype,wobbletype,
cwtype,ccwtype,stopwaittimetype,angularvelocitytype,
respecttype,elbowtype,shouldertype,fliptype,lineartype,
jointspacetype,loadtype);
edittypes = (getcmd,savecmd,insertcmd,renamecmd,startcmd,gocmd,proceedcmd,
stepcmd,sstepcmd,nstepcmd,gstepcmd,executecmd,setcmd,tracecmd,
breakcmd,unbreakcmd,tbreakcmd,definecmd,markcmd,unmarkcmd,
popcmd,atcmd,calibratecmd);
token = record
next: tokenp;
case ttype: tokentypes of
constype: (cons: nodep);
comnttype: (len: integer; str: strngp);
delimtype: (ch: ascii);
reswdtype: (case rtype: reswdtypes of
stmnttype: (stmnt: stmntypes);
filtype: (filler: filtypes);
clsetype: (clause: clsetypes);
decltype: (decl: datatypes);
optype: (op: exprtypes);
edittype: (ed: edittypes) );
identtype: (id: identp);
labeldeftype: (lab: varidefp);
macpartype: (mpar: varidefp);
end;
resword = record
next: reswordp;
length: integer;
name: strngp;
case rtype: reswdtypes of
stmnttype: (stmnt: stmntypes);
filtype: (filler: filtypes);
clsetype: (clause: clsetypes);
decltype: (decl: datatypes);
optype: (op: exprtypes);
edittype: (ed: edittypes);
end;
(* process descriptor blocks & environment record definitions *)
queuetypes = (nullqueue,nowrunning,runqueue,inputqueue,eventqueue,sleepqueue,
forcewait,devicewait,joinwait,proccall);
pdb = packed record
nextpdb,next: pdbp; (* for list of all/active pdb's *)
level: 0..255; (* lexical level *)
mode: 0..255; (* expression/statement/sub-statement *)
priority: 0..255; (* probably never greater than 3? *)
status: queuetypes; (* what are we doing *)
env: envheaderp;
spc: statementp; (* current statement *)
epc: nodep; (* current expression (if any) *)
sp: nodep; (* intermediate value stack *)
cm: cmoncbp; (* if we're a cmon point to our definition *)
mech: framep; (* current device being used *)
linenum: integer; (* used by editor/debugger *)
case procp: boolean of (* true if we're a procedure *)
true: (opdb: pdbp; (* pdb to restore when procedure exits *)
pdef: nodep); (* procedure definition node *)
false: (evt: eventp; (* event to signal when process goes away *)
sdef: statementp); (* first statement where process was defined *)
end;
envheader = packed record
parent: envheaderp;
env: array [0..4] of environp;
varcnt: 0..255; (* # of variables in use ??? *)
case procp: boolean of (* true if we're a procedure *)
true: (proc: nodep);
false:(block: statementp);
end;
enventry = record
case etype: datatypes of
svaltype: (s: scalar);
vectype: (v: vectorp);
transtype: (t: transp);
frametype: (f: framep);
eventtype: (evt: eventp);
strngtype: (length: integer; str: strngp);
cmontype: (c: cmoncbp);
proctype: (p: nodep; penv: envheaderp);
reftype: (r: enventryp);
arraytype: (a: envheaderp; bnds: nodep);
end;
environment = record
next: environp;
vals: array [0..9] of enventryp;
end;
cmoncb = record
running, enabled: boolean; (* cmon's status *)
cmon: statementp;
pdb: pdbp;
evt: eventp;
fbits: integer; (* bits for force sensing *)
oldcmon: cmoncbp; (* for debugger *)
end;
(* print related records: *)
cursorp = record
cline,ind: integer;
case stmntp: boolean of
true: (st: statementp);
false: (nd: nodep);
end;
linerec = record
next: linerecp;
start,length: integer
end;
listingarray = packed array [0..listinglength] of ascii;
(* global variables *)
var listing: listingarray; (* first 150 chars are used by expression editor *)
(* next 40 by header & trailer lines *)
screenheight,dispHeight: integer;
smartTerminal: boolean; (* true = insert/delete, false = redraw line *)
lbuf: array [1..160] of ascii;
ppBuf: array [1..100] of ascii;
lines: array [1..maxLines] of linerecp; (* what's on the screen + some *)
ppLines: array [1..maxPPLines] of linerecp; (* for page printer *)
ppBufp,oppBufp,ppOffset,ppSize,nmarks: integer;
marks: array [1..20] of integer;
cursorStack: array [1..15] of cursorp;
lbufp,cursor,ocur,cursorLine,fieldnum,lineNum,findLine,pcLine: integer;
firstDline,topDline,botDline,firstLine,lastLine,curLine: integer;
freeLines,oldLines: linerecp;
setUp,setExpr,setCursor,dontPrint,outFilep,collect,fParse,sParse,
eofError,endOfLine,backup,expandmacros,flushcomments,checkDims,
shownLine: boolean;
reswords: array [0..26] of reswordp;
idents: array [0..26] of identp;
sysVars: varidefp;
dProg: statementp;
curBlock, newDeclarations, findStmnt: statementp;
macrostack: array [1..10] of tokenp;
curmacstack: array [1..10] of varidefp;
macrodepth: integer;
curtoken: token;
file1,file2,file3,file4,file5,outFile: atext;
filedepth, errCount, sCursor: integer;
curChar, maxChar, curFLine, curPage: integer;
nodim, distancedim, timedim, angledim,
forcedim, torquedim, veldim, angveldim: varidefp;
fvstiffdim, mvstiffdim: nodep;
pnode: nodep;
xhat,yhat,zhat,nilvect: vectorp; (* various constant pointers *)
niltrans: transp;
gpark, rpark: transp; (* arm park positions *)
bpts: array [1..maxBpts] of statementp; (* debugging crap *)
tbpts: array [1..maxTBpts] of statementp;
nbpts,ntbpts,debugLevel: integer;
eCurInt: pdbp;
debugPdbs: array [0..10] of pdbp;
singleThreadMode,tSingleThreadMode: boolean;
STLevel: integer; (* set by GO *)
(* external routines *)
function initScreen(l: listingarray): integer; extern; (* from AUXIO.FAI *)
procedure reInitScreen; extern;
procedure resetScreen; extern;
procedure clearScreen; extern;
procedure echo(on: boolean); extern;
procedure beep; extern;
procedure showCursor(line,col: integer); extern;
procedure outLine(line,col,start,length: integer); extern;
function getChar: ascii; extern;
procedure outChar(line,col: integer; ch: ascii; bold: boolean); extern;
procedure insChar(line,col: integer; ch: ascii); extern;
procedure delChar(line,col: integer); extern;
procedure insLine(line,num: integer); extern;
procedure delLine(line,num: integer); extern;
function newToken: tokenp; extern; (* from ALLOC.PAS *)
procedure relToken(t: tokenp); extern;
function newVector: vectorp; extern;
procedure relVector(v: vectorp); extern;
function newTrans: transp; extern;
procedure relTrans(n: transp); extern;
function newNode: nodep; extern;
procedure relNode(n: nodep); extern;
function newStrng: strngp; extern;
procedure relStrng(n: strngp); extern;
function newIdent: identp; extern;
procedure relIdent(n: identp); extern;
function newVaridef: varidefp; extern;
procedure relVaridef(n: varidefp); extern;
function newStatement: statementp; extern;
procedure relStatement(n: statementp); extern;
function newEheader: envheaderp; extern;
function newEnvironment: environp; extern;
function newEentry: enventryp; extern;
function newPdb: pdbp; extern;
procedure relPdb(p: pdbp); extern;
procedure freeStatement(s: statementp); extern; (* from FREE.PAS *)
procedure freeNode(n: nodep); extern;
procedure freStrng(st: strngp); extern;
function getCurInt: pdbp; extern; (*only sail*) (* from INTERP.PAS *)
procedure setCurInt(p: pdbp); extern; (*only sail*)
function getAllPdbs: pdbp; extern; (*only sail*)
procedure setSingleThreadMode(b: boolean); extern; (*only sail*)
procedure flushLevel(dLev: integer); extern;
procedure flushAll(p: pdbp; dLev: integer); extern;
procedure flushPdb(p: pdbp); extern;
procedure flushKids(p: pdbp; zapit: boolean); extern;
procedure unwind(p: pdbp; eLev: integer); extern;
procedure Interp(debugLevel: integer); extern;
function getELev(hdr: envheaderp): integer; extern;
function getEntry (level, offset: byte): enventryp; extern;
procedure makeVar(e: enventryp; vari: varidefp; tbits: integer); extern;
procedure killVar(e: enventryp); extern;
procedure swap(newp: pdbp); extern;
function pop: nodep; extern;
procedure prntStrng(length: integer; s: strngp); extern;
procedure passConstants(var x,y,z,nv: vectorp; var g,r,nt: transp); extern;
procedure calibrate; extern;
function getsysVars: varidefp; (* for INTERP.PAS *)
begin getsysVars := sysVars; end;
function taxis (t: transp): vectorp; extern; (* from ARITH.PAS *)
function tmagn (t: transp): scalar; extern;
procedure relExpr(n: nodep); forward;
procedure borderLines; forward;
procedure putReal(s: real); forward;
function copyExpr(n: nodep; lcp: boolean): nodep; forward;
procedure setECurInt; forward;
function exprParse: nodep; forward;
procedure errprnt; forward;
procedure setUpStmnt; forward;
procedure flushOldEnvironments(dLev: integer); forward;
procedure executeStmnt(st: statementp); forward;
(* aux routines: GetAChar,out1Line,clearLine,appendEnd,makeOuterBlock *)
function getAChar: ascii;
var ch: ascii; i: integer;
begin
repeat ch := getChar until ch <> chr(LF); (* skip over any <lf>'s *)
i := ord(ch);
if i > deletekey then ch := chr(i-128) (* strip off SAIL control bit *)
else if i < ord(' ') then (* or undo ASCII control key *)
if ((i < ctlH) or (CR < i)) and (i <> sailundline) then ch := chr(i+64);
getAChar := ch;
end;
procedure out1Line(line,start,length: integer);
begin
if length > 79 then length := 79; (* only display first 79 chars *)
outLine(line,1,start,length);
end;
procedure clearLine(i: integer);
var ch: ascii;
begin
ch := listing[1];
listing[1] := ' ';
outLine(i,1,1,1);
listing[1] := ch;
end;
procedure appendEnd(s,so: statementp);
var st: statementp;
begin
if so <> nil then
begin
st := newStatement;
so↑.next := st;
with st↑ do
begin
last := so;
blkid := nil;
stype := endtype;
bparent := s;
end;
end;
end;
procedure makeOuterBlock; (* Make initial BEGIN-END block *)
begin
dprog := newStatement;
with dprog↑ do
begin
stype := progtype;
pcode := newStatement;
with pcode↑ do
begin
stype := blocktype;
blkid := nil;
level := 1;
numvars := 0;
variables := nil;
bparent := nil;
end;
appendEnd(pcode,pcode);
with pcode↑ do bcode := next;
errors := 0;
appendEnd(dprog,pcode);
end;
setUpStmnt;
end;
(* lookup routines: upperCase,eqStrng,hash,resLookup,idLookup,freeIds,findResword *)
function upperCase(c: ascii): ascii;
begin
if (c < chr(smallA)) or (chr(smallZ) < c) then upperCase := c
else upperCase := chr(ord(c) - smallA + ord('A')); (* c - 'a' + 'A' *)
end;
function eqStrng(s1: strngp; s2,len: integer): boolean;
var i,j: integer; b: boolean;
begin
b := true;
i := 0;
j := 1;
repeat
if upperCase(s1↑.ch[j]) <> upperCase(listing[s2+i]) then b := false
else
begin
i := i + 1;
if j < 10 then j := j + 1
else begin j := 1; s1 := s1↑.next end;
end
until (i >= len) or not b;
eqStrng := b;
end;
function hash(ch: ascii): integer;
var i: integer;
begin (* this will only work for ascii *)
i := ord(ch);
if ('A' <= ch) and (ch <= 'Z') then i := i - ord('A') + 1
else if (chr(smallA) <= ch) and (ch <= chr(smallZ)) then i := i - smallA + 1
else i := 0;
hash := i;
end;
function resLookup(str,len: integer): reswordp;
var res: reswordp; b: boolean;
begin
res := reswords[hash(listing[str])]; (* look in right bucket *)
b := true;
while (res <> nil) and b do
if res↑.length = len then
if eqStrng(res↑.name,str,len) then b := false
else res := res↑.next
else res := res↑.next;
resLookup := res;
end;
function idLookup(str,len: integer): identp;
var id: identp; b: boolean;
begin
id := idents[hash(listing[str])]; (* look in right bucket *)
b := true;
while (id <> nil) and b do
if id↑.length = len then
if eqStrng(id↑.name,str,len) then b := false
else id := id↑.next
else id := id↑.next;
idLookup := id;
end;
procedure freeIds;
var i: integer; id,idp,idn: identp; st,stp: strngp;
begin
for i := 1 to 26 do
begin
idp := nil;
id := idents[i];
while id <> nil do
with id↑ do
begin
idn := next;
if predefined = nil then
begin (* flush id now *)
st := name; (* done with string *)
while st <> nil do
begin stp := st↑.next; relStrng(st); st := stp end;
relIdent(id); (* and ident *)
end
else
begin
if idp = nil then idents[i] := id else idp↑.next := id;
idp := id;
end;
id := idn;
end;
if idp = nil then idents[i] := nil;
end;
end;
function findResword(what: reswdtypes; which, where: integer): reswordp;
var b: boolean; i: integer; r: reswordp;
begin
b := true;
i := where;
while b and (i<=26) do
begin (* try to find reserved word & print it out *)
r := reswords[i]; (* try next bucket *)
while b and (r <> nil) do
with r↑ do
if (what=rtype) and (which = ord(stmnt)) then b := false else r := next;
i := i + 1;
end;
findResword := r;
end;
(* routine to make reserved words: initReswords *)
procedure initReswords;
var i: integer; res: reswordp; Estr: strngp;
function makeResword(t: reswdtypes; s: cstring): reswordp;
var res: reswordp; str: strngp; i,len: integer;
begin
new(res);
with res↑ do
begin
rtype := t;
str := newStrng;
str↑.ch := s;
name := str;
len := 10;
while s[len] = ' ' do len := len - 1;
length := len;
end;
i := hash(s[1]); (* find proper bucket *)
res↑.next := reswords[i]; (* link us onto list of reserved words *)
reswords[i] := res;
makeResword := res;
end;
procedure stmake(st: stmntypes; s: cstring);
var res: reswordp;
begin
res := makeResword(stmnttype,s);
res↑.stmnt := st;
end;
procedure filmake(fil: filtypes; s: cstring);
var res: reswordp;
begin
res := makeResword(filtype,s);
res↑.filler := fil;
end;
procedure clmake(cl: clsetypes; s: cstring);
var res: reswordp;
begin
res := makeResword(clsetype,s);
res↑.clause := cl;
end;
procedure dcmake(dc: datatypes; s: cstring);
var res: reswordp;
begin
res := makeResword(decltype,s);
res↑.decl := dc;
end;
procedure opmake(opr: exprtypes; s: cstring);
var res: reswordp;
begin
res := makeResword(optype,s);
res↑.op := opr;
end;
procedure editmake(ed: edittypes; s: cstring);
var res: reswordp;
begin
res := makeResword(edittype,s);
res↑.ed := ed;
end;
begin
for i := 0 to 26 do reswords[i] := nil;
stmake(progtype,'PROGRAM ');
stmake(blocktype,'BEGIN ');
stmake(coblocktype,'COBEGIN ');
stmake(coendtype,'COEND ');
stmake(endtype,'END ');
stmake(assigntype,':= ');
stmake(fortype,'FOR ');
stmake(iftype,'IF ');
stmake(whiletype,'WHILE ');
stmake(casetype,'CASE ');
stmake(returntype,'RETURN ');
stmake(printtype,'PRINT ');
stmake(prompttype,'PROMPT ');
stmake(pausetype,'PAUSE ');
stmake(aborttype,'ABORT ');
stmake(signaltype,'SIGNAL ');
stmake(waittype,'WAIT ');
stmake(enabletype,'ENABLE ');
stmake(disabletype,'DISABLE ');
stmake(cmtype,'ON ');
stmake(affixtype,'AFFIX ');
stmake(unfixtype,'UNFIX ');
stmake(movetype,'MOVE ');
stmake(operatetype,'OPERATE ');
stmake(opentype,'OPEN ');
stmake(closetype,'CLOSE ');
stmake(centertype,'CENTER ');
stmake(floattype,'FLOAT ');
stmake(stoptype,'STOP ');
stmake(retrytype,'RETRY ');
stmake(requiretype,'REQUIRE ');
stmake(definetype,'DEFINE ');
stmake(dimdeftype,'DIMENSION ');
stmake(commenttype,'COMMENT ');
stmake(setbasetype,'SETBASE ');
stmake(wristtype,'WRIST ');
stmake(saytype,'SAY ');
stmake(armmagictype,'ARM_MAGIC ');
filmake(abouttype,'ABOUT ');
filmake(alongtype,'ALONG ');
filmake(attype,'AT ');
filmake(bytype,'BY ');
filmake(defertype,'DEFER ');
filmake(dotype,'DO ');
filmake(elsetype,'ELSE ');
res := makeResword(filtype,'ERROR_MODE');
res↑.name↑.next := newStrng;
res↑.name↑.next↑.ch := 'S ';
res↑.length := 11;
res↑.filler := errmodestype;
filmake(fromtype,'FROM ');
filmake(handtype,'HAND ');
filmake(intype,'IN ');
filmake(nonrigidlytype,'NONRIGIDLY');
filmake(rigidlytype,'RIGIDLY ');
res := makeResword(filtype,'SOURCE_FIL');
Estr := newStrng;
Estr↑.ch := 'E ';
res↑.name↑.next := Estr;
res↑.length := 11;
res↑.filler := sourcefiletype;
filmake(steptype,'STEP ');
filmake(thentype,'THEN ');
filmake(totype,'TO ');
filmake(untltype,'UNTIL ');
filmake(viatype,'VIA ');
filmake(withtype,'WITH ');
filmake(worldtype,'WORLD ');
filmake(zeroedtype,'ZEROED ');
filmake(oftype,'OF ');
filmake(wheretype,'WHERE ');
filmake(nowaittype,'NOWAIT ');
filmake(notype,'NO ');
filmake(righttype,'RIGHT ');
filmake(lefttype,'LEFT ');
filmake(uptype,'UP ');
filmake(downtype,'DOWN ');
filmake(motiontype,'MOTION ');
clmake(approachtype,'APPROACH ');
clmake(arrivaltype,'ARRIVAL ');
clmake(departuretype,'DEPARTURE ');
clmake(departingtype,'DEPARTING ');
clmake(durationtype,'DURATION ');
clmake(errortype,'ERROR ');
clmake(forcetype,'FORCE ');
res := makeResword(clsetype,'FORCE_FRAM');
res↑.name↑.next := Estr;
res↑.length := 11;
res↑.clause := forceframetype;
res := makeResword(clsetype,'FORCE_WRIS');
res↑.name↑.next := newStrng;
res↑.name↑.next↑.ch := 'T ';
res↑.length := 11;
res↑.clause := forcewristtype;
clmake(gathertype,'GATHER ');
res := makeResword(clsetype,'NILDEPROAC');
res↑.name↑.next := newStrng;
res↑.name↑.next↑.ch := 'H ';
res↑.length := 11;
res↑.clause := nildeproachtype;
clmake(nullingtype,'NULLING ');
clmake(stiffnesstype,'STIFFNESS ');
clmake(torquetype,'TORQUE ');
clmake(velocitytype,'VELOCITY ');
clmake(wobbletype,'WOBBLE ');
clmake(cwtype,'CW ');
clmake(cwtype,'CLOCKWISE ');
clmake(ccwtype,'CCW ');
res := makeResword(clsetype,'COUNTER_CL');
res↑.name↑.next := newStrng;
res↑.name↑.next↑.ch := 'OCKWISE ';
res↑.length := 17;
res↑.clause := ccwtype;
res := makeResword(clsetype,'ANGULAR_VE');
res↑.name↑.next := newStrng;
res↑.name↑.next↑.ch := 'LOCITY ';
res↑.length := 16;
res↑.clause := angularvelocitytype;
res := makeResword(clsetype,'STOP_WAIT_');
res↑.name↑.next := newStrng;
res↑.name↑.next↑.ch := 'TIME ';
res↑.length := 14;
res↑.clause := stopwaittimetype;
clmake(respecttype,'RESPECT ');
clmake(elbowtype,'ELBOW ');
clmake(shouldertype,'SHOULDER ');
clmake(fliptype,'FLIP ');
clmake(lineartype,'LINEAR ');
res := makeResword(clsetype,'JOINT_SPAC');
res↑.name↑.next := newStrng;
res↑.name↑.next↑.ch := 'E ';
res↑.length := 11;
res↑.clause := jointspacetype;
clmake(loadtype,'LOAD ');
dcmake(arraytype,'ARRAY ');
dcmake(eventtype,'EVENT ');
dcmake(labeltype,'LABEL ');
dcmake(proctype,'PROCEDURE ');
dcmake(reftype,'REFERENCE ');
dcmake(svaltype,'SCALAR ');
dcmake(valtype,'VALUE ');
opmake(sltop,'< ');
opmake(sleop,'<= ');
opmake(sleop,'=< ');
opmake(seqop,'= ');
opmake(sgeop,'>= ');
opmake(sgeop,'=> ');
opmake(sgtop,'> ');
opmake(sneop,'<> ');
opmake(notop,'NOT ');
opmake(orop,'OR ');
opmake(xorop,'XOR ');
opmake(andop,'AND ');
opmake(eqvop,'EQV ');
opmake(sexpop,'↑ ');
opmake(maxop,'MAX ');
opmake(minop,'MIN ');
opmake(intop,'INT ');
opmake(idivop,'DIV ');
opmake(modop,'MOD ');
opmake(sqrtop,'SQRT ');
opmake(logop,'LOG ');
opmake(expop,'EXP ');
opmake(timeop,'RUNTIME ');
opmake(sinop,'SIN ');
opmake(cosop,'COS ');
opmake(tanop,'TAN ');
opmake(asinop,'ASIN ');
opmake(acosop,'ACOS ');
opmake(atan2op,'ATAN2 ');
opmake(vdotop,'. ');
opmake(unitvop,'UNIT ');
opmake(vmakeop,'VECTOR ');
opmake(wrtop,'WRT ');
opmake(tposop,'POS ');
opmake(taxisop,'AXIS ');
opmake(tmakeop,'TRANS ');
opmake(fmakeop,'FRAME ');
opmake(torientop,'ORIENT ');
opmake(tinvrtop,'INV ');
opmake(vsaxwrop,'ROT ');
opmake(constrop,'CONSTRUCT ');
opmake(deproachop,'DEPROACH ');
opmake(ftofop,'-> ');
opmake(queryop,'QUERY ');
opmake(inscalarop,'INSCALAR ');
opmake(adcop,'ADC ');
opmake(dacop,'DAC ');
opmake(addop,'+ ');
opmake(subop,'- ');
opmake(mulop,'* ');
opmake(divop,'/ ');
(* opmake(absop,'| '); since dumb SAIL doesn't handle the | char *)
res := makeResword(optype,'| ');
res↑.op := absop;
res↑.name↑.ch[1] := chr(vbar);
opmake(grinchop,'# ');
editmake(getcmd,'GET '); (* for use by the editor/debugger *)
editmake(savecmd,'SAVE ');
editmake(insertcmd,'INSERT ');
editmake(renamecmd,'RENAME ');
editmake(startcmd,'START ');
editmake(startcmd,'RUN ');
editmake(gocmd,'GO ');
editmake(proceedcmd,'PROCEED ');
editmake(sstepcmd,'SSTEP ');
editmake(nstepcmd,'NSTEP ');
editmake(gstepcmd,'GSTEP ');
editmake(executecmd,'EXECUTE ');
editmake(setcmd,'SET ');
editmake(tracecmd,'TRACE ');
editmake(breakcmd,'BREAK ');
editmake(unbreakcmd,'UNBREAK ');
editmake(tbreakcmd,'TBREAK ');
editmake(markcmd,'MARK ');
editmake(unmarkcmd,'UNMARK ');
editmake(popcmd,'POP ');
editmake(calibratecmd,'CALIBRATE ');
filmake(offtype,'OFF ');
filmake(ppsizetype,'BOTSIZE ');
filmake(collecttype,'COLLECT ');
filmake(alltype,'ALL ');
filmake(lextype,'LEX ');
end;
(* routine to make predeclared identifiers & constants: initIdents *)
procedure initIdents;
var i: integer; id: identp; v,vp: varidefp; n: nodep; str,Rstr: strngp;
sfId,degId,secId: identp; t,tp: tokenp; (* for macro defs *)
function makeIdent(s: cstring): identp;
var id: identp; str: strngp; i,len: integer;
begin
id := newIdent;
with id↑ do
begin
predefined := nil;
str := newStrng;
str↑.ch := s;
name := str;
len := 10;
while s[len] = ' ' do len := len - 1;
length := len;
end;
i := hash(id↑.name↑.ch[1]); (* find proper bucket *)
id↑.next := idents[i]; (* link us onto list of identifiers *)
idents[i] := id;
makeIdent := id;
end;
function DimMake(s: cstring): varidefp;
var id: identp; vdef: varidefp; n: nodep;
begin
id := makeIdent(s);
vdef := newVaridef;
id↑.predefined := vdef;
n := newNode; (* need to make up a dimension node *)
with n↑ do
begin
next := nil;
ntype := dimnode;
time := 0;
distance := 0;
angle := 0;
dforce := 0;
end;
with vdef↑ do
begin
name := id;
vtype := dimensiontype;
dtype := vdef; (* a bit circular, but... *)
offset := 0;
tbits := 0;
dbits := 0;
dim := n;
dnext := nil;
end;
DimMake := vdef;
end;
function Idmake(s: cstring; d: datatypes; vdim: varidefp; o: integer): identp;
var id: identp; vdef: varidefp;
begin
id := makeIdent(s);
vdef := newVaridef;
id↑.predefined := vdef;
with vdef↑ do
begin
name := id;
vtype := d;
dtype := vdim;
level := 0;
offset := o;
tbits := 0;
dbits := 0;
next := sysVars;
dnext := nil;
end;
sysVars := vdef; (* add us to list of system variables *)
Idmake := id;
end;
function ConMake(s: cstring; d: datatypes; vdim: varidefp;
sv: real; n: nodep): identp;
var id: identp; vdef: varidefp;
begin
id := makeIdent(s);
vdef := newVaridef;
id↑.predefined := vdef;
if n = nil then (* need to make up a new constant node *)
begin
n := newNode;
with n↑ do
begin
next := nil;
ntype := leafnode;
ltype := d;
if d = svaltype then s := sv;
end;
end;
with vdef↑ do
begin
name := id;
vtype := pconstype;
dtype := vdim;
offset := 0;
tbits := 0;
dbits := 0;
c := n;
dnext := nil;
end;
ConMake := id;
end;
function MacMake(s: cstring): identp;
var id: identp; vdef: varidefp;
begin
id := makeIdent(s);
vdef := newVaridef;
id↑.predefined := vdef;
vdef↑.name := id;
vdef↑.vtype := macargtype;
MacMake := id;
end;
function CToken(num: real; tp: tokenp): tokenp;
var t: tokenp; n: nodep;
begin
t := newToken;
if tp <> nil then tp↑.next := t;
n := newNode;
t↑.ttype := constype;
t↑.cons := n;
n↑.ntype := leafnode;
n↑.ltype := svaltype;
n↑.s := num;
CToken := t;
end;
function IToken(i: identp; tp: tokenp): tokenp;
var t: tokenp;
begin
t := newToken;
if tp <> nil then tp↑.next := t;
t↑.ttype := identtype;
t↑.id := i;
IToken := t;
end;
function RToken(r: reswdtypes): tokenp;
var t: tokenp;
begin
t := newToken;
t↑.ttype := reswdtype;
t↑.rtype := r;
RToken := t;
end;
function WithToken(tp: tokenp): tokenp;
var t: tokenp;
begin
t := RToken(filtype);
if tp <> nil then tp↑.next := t;
t↑.filler := withtype;
WithToken := t;
end;
function OpToken(tp: tokenp): tokenp;
var t: tokenp;
begin
t := RToken(optype);
if tp <> nil then tp↑.next := t;
t↑.op := seqop;
OpToken := t;
end;
function ClToken(cl: clsetypes; tp: tokenp): tokenp;
var t: tokenp;
begin
t := RToken(clsetype);
if tp <> nil then tp↑.next := t;
t↑.clause := cl;
ClToken := t;
end;
function FilToken(fil: filtypes; tp: tokenp): tokenp;
var t: tokenp;
begin
t := RToken(filtype);
if tp <> nil then tp↑.next := t;
t↑.filler := fil;
FilToken := t;
end;
procedure SpdSt(id: identp; spd: real);
var t,tp: tokenp;
begin
t := IToken(sfId,nil);
id↑.predefined↑.marg := t;
tp := RToken(stmnttype);
t↑.next := tp;
tp↑.stmnt := assigntype;
t := CToken(spd,tp);
t↑.next := nil;
end;
procedure SpdCl(id: identp; spd: real);
var t,tp: tokenp;
begin
t := WithToken(nil);
id↑.predefined↑.marg := t;
tp := IToken(sfId,t);
t := OpToken(tp);
tp := CToken(spd,t);
tp↑.next := nil;
end;
procedure SwtCl(id: identp; swt: real);
var t,tp: tokenp;
begin
t := WithToken(nil);
id↑.predefined↑.marg := t;
tp := ClToken(stopwaittimetype,t);
t := OpToken(tp);
tp := CToken(swt,t);
tp↑.next := nil;
end;
begin
for i := 0 to 26 do idents[i] := nil;
nodim := DimMake('DIMENSIONL'); (* define basic dimension types *)
nodim↑.name↑.name↑.next := newStrng;
nodim↑.name↑.name↑.next↑.ch := 'ESS ';
nodim↑.name↑.length := 13;
angledim := DimMake('ANGLE ');
angledim↑.dim↑.angle := 64; (* really 1, but use 64 so sqrt has a chance *)
distancedim := DimMake('DISTANCE ');
distancedim↑.dim↑.distance := 64;
timedim := DimMake('TIME ');
timedim↑.dim↑.time := 64;
forcedim := DimMake('FORCE ');
forcedim↑.dim↑.dforce := 64;
torquedim := DimMake('TORQUE ');
torquedim↑.dim↑.dforce := 64; (* torque = distance * force *)
torquedim↑.dim↑.distance := 64;
veldim := DimMake('VELOCITY ');
veldim↑.dim↑.time := -64; (* velocity = distance / time *)
veldim↑.dim↑.distance := 64;
angveldim := DimMake('ANGULAR_VE');
angveldim↑.name↑.name↑.next := newStrng;
angveldim↑.name↑.name↑.next↑.ch := 'LOCITY ';
angveldim↑.name↑.length := 16;
angveldim↑.dim↑.time := -64; (* angular_velocity = angle / time *)
angveldim↑.dim↑.angle := 64;
fvstiffdim := newNode; (* stiffness fv = force / distance *)
with fvstiffdim↑ do
begin
next := nil;
ntype := dimnode;
time := 0;
distance := -64;
angle := 0;
dforce := 64;
end;
mvstiffdim := newNode; (* stiffness mv = torque / angle *)
with mvstiffdim↑ do
begin
next := nil;
ntype := dimnode;
time := 0;
distance := 64;
angle := -64;
dforce := 64;
end;
sysVars := nil; (* declare all the system variables *)
id := Idmake('GARM ',frametype,distancedim,0);
id := Idmake('GARM_ERROR',svaltype,nodim,1);
id := Idmake('GHAND ',svaltype,distancedim,2);
id := Idmake('GHAND_ERRO',svaltype,nodim,3);
Rstr := newStrng;
Rstr↑.ch := 'R ';
id↑.name↑.next := Rstr;
id↑.length := 11;
id := Idmake('RARM ',frametype,distancedim,4);
id := Idmake('RARM_ERROR',svaltype,nodim,5);
id := Idmake('RHAND ',svaltype,distancedim,6);
id := Idmake('RHAND_ERRO',svaltype,nodim,7);
id↑.name↑.next := Rstr;
id↑.length := 11;
id := Idmake('DRIVER ',svaltype,nodim,8); (* same as DRIVER_TURNS *)
id := Idmake('DRIVER_TUR',svaltype,nodim,8); (* same as DRIVER *)
id↑.name↑.next := newStrng;
id↑.name↑.next↑.ch := 'NS ';
id↑.length := 12;
sysVars := sysVars↑.next; (* don't want both in list of sysVars *)
id := Idmake('DRIVER_ERR',svaltype,nodim,9);
id↑.name↑.next := newStrng;
id↑.name↑.next↑.ch := 'OR ';
id↑.length := 12;
id := Idmake('DRIVER_TIP',frametype,distancedim,10);
id := Idmake('DRIVER_GRA',frametype,distancedim,11);
id↑.name↑.next := newStrng;
id↑.name↑.next↑.ch := 'SP ';
id↑.length := 12;
id := Idmake('VISE ',svaltype,distancedim,12);
id := Idmake('VISE_ERROR',svaltype,nodim,13);
id := Idmake('FIXED_JAW ',frametype,distancedim,14);
id := Idmake('MOVING_JAW',frametype,distancedim,15);
sfId := Idmake('SPEED_FACT',svaltype,nodim,16);
sfid↑.name↑.next := newStrng;
sfid↑.name↑.next↑.ch := 'OR ';
sfId↑.length := 12;
v := sysVars; (* reverse the list so it's in the right order *)
while v <> nil do
begin
vp := v↑.next;
if vp <> nil then vp↑.dnext := v (* set up a back pointer for next step *)
else sysVars := v;
v↑.next := v↑.dnext; (* use back pointer to reverse list *)
v↑.dnext := nil;
v := vp;
end;
(* now make up the constants *)
id := ConMake('RPARK ',transtype,distancedim,0.0,nil);
id↑.predefined↑.c↑.t := rpark;
id := ConMake('GPARK ',transtype,distancedim,0.0,nil);
id↑.predefined↑.c↑.t := gpark;
id := ConMake('NILTRANS ',transtype,distancedim,0.0,nil);
n := id↑.predefined↑.c;
n↑.t := niltrans;
id := ConMake('NILROT ',transtype,angledim,0.0,n);
id := ConMake('STATION ',transtype,distancedim,0.0,n);
id := ConMake('XHAT ',vectype,nodim,0.0,nil);
id↑.predefined↑.c↑.v := xhat;
id := ConMake('YHAT ',vectype,nodim,0.0,nil);
id↑.predefined↑.c↑.v := yhat;
id := ConMake('ZHAT ',vectype,nodim,0.0,nil);
id↑.predefined↑.c↑.v := zhat;
id := ConMake('NILVECT ',vectype,nodim,0.0,nil);
id↑.predefined↑.c↑.v := nilvect;
id := ConMake('TRUE ',svaltype,nodim,1.0,nil);
n := id↑.predefined↑.c;
degId := ConMake('DEG ',svaltype,angledim,0.0,n);
id := ConMake('DEGREES ',svaltype,angledim,0.0,n);
id := ConMake('INCH ',svaltype,distancedim,0.0,n);
id := ConMake('INCHES ',svaltype,distancedim,0.0,n);
id := ConMake('OUNCES ',svaltype,forcedim,0.0,n);
id := ConMake('OZ ',svaltype,forcedim,0.0,n);
secId := ConMake('SEC ',svaltype,timedim,0.0,n);
id := ConMake('SECOND ',svaltype,timedim,0.0,n);
id := ConMake('SECONDS ',svaltype,timedim,0.0,n);
id := ConMake('FALSE ',svaltype,nodim,0.0,nil);
id := ConMake('CM ',svaltype,distancedim,0.3937008,nil);
id := ConMake('GM ',svaltype,forcedim,0.035274,nil);
id := ConMake('RADIANS ',svaltype,angledim,57.295779,nil);
id := ConMake('PI ',svaltype,nodim,3.1415927,nil);
id := ConMake('LBS ',svaltype,forcedim,16.0,nil);
id := ConMake('RPM ',svaltype,angveldim,6.0,nil);
id := ConMake('CRLF ',strngtype,nodim,0.0,nil);
str := newStrng;
str↑.ch[1] := chr(CR); (* cr *)
str↑.ch[2] := chr(LF); (* lf *)
id↑.predefined↑.c↑.str := str;
id↑.predefined↑.c↑.length := 2;
id := ConMake('PANIC_BUTT',svaltype,nodim,1024.0,nil); (* '2000 *)
id↑.name↑.next := newStrng;
id↑.name↑.next↑.ch := 'ON ';
id↑.length := 12;
id := ConMake('EXCESSIVE_',svaltype,nodim,2048.0,nil); (* '4000 *)
id↑.name↑.next := newStrng;
id↑.name↑.next↑.ch := 'FORCE ';
id↑.length := 15;
id := ConMake('TIME_OUT ',svaltype,nodim,4096.0,nil); (* '10000 *)
id := MacMake('DIRECTLY '); (* now make predeclared macros *)
t := WithToken(nil); (* "WITH APPROACH = NILDEPROACH" *)
id↑.predefined↑.marg := t;
tp := ClToken(approachtype,t);
t := OpToken(tp);
tp := ClToken(nildeproachtype,t);
t := WithToken(tp); (* "WITH DEPARTURE = NILDEPROACH" *)
tp := ClToken(departuretype,t);
t := OpToken(tp);
tp := ClToken(nildeproachtype,t);
tp↑.next := nil;
SpdSt(MacMake('QUICK '),1.0); (* QUICK = "SPEEDFACTOR := 1.0" *)
SpdSt(MacMake('SLOW '),3.0); (* SLOW = "SPEEDFACTOR := 3.0" *)
SpdSt(MacMake('CAUTIOUS '),4.0); (* CAUTIOUS = "SPEEDFACTOR := 4.0" *)
SpdCl(MacMake('QUICKLY '),1.0); (* QUICKLY = "WITH SPEEDFACTOR = 1.0" *)
SpdCl(MacMake('NORMALLY '),2.0); (* NORMALLY = "WITH SPEEDFACTOR = 2.0" *)
SpdCl(MacMake('SLOWLY '),3.0); (* SLOWLY = "WITH SPEEDFACTOR = 3.0" *)
SpdCl(MacMake('CAUTIOUSLY'),4.0); (* CAUTIOUSLY = "WITH SPEEDFACTOR = 4.0" *)
id := MacMake('APPROXIMAT');
id↑.name↑.next := newStrng;
id↑.name↑.next↑.ch := 'ELY ';
id↑.length := 13;
t := WithToken(nil); (* APPROXIMATELY = "WITH NO NULLING" *)
id↑.predefined↑.marg := t;
tp := RToken(filtype);
t↑.next := tp;
tp↑.filler := notype;
t := ClToken(nullingtype,tp);
t↑.next := nil;
id := MacMake('PRECISELY ');
t := WithToken(nil); (* PRECISELY = "WITH NULLING" *)
id↑.predefined↑.marg := t;
tp := ClToken(nullingtype,t);
tp↑.next := nil;
id := MacMake('LINEARLY ');
t := WithToken(nil); (* LINEARLY = "WITH LINEAR MOTION" *)
id↑.predefined↑.marg := t;
tp := ClToken(lineartype,t);
t := RToken(filtype);
tp↑.next := t;
t↑.filler := motiontype;
t↑.next := nil;
SwtCl(MacMake('GENTLY '),0.0); (* GENTLY = "WITH STOPWAITTIME = 0.0" *)
SwtCl(MacMake('TIGHTLY '),0.5); (* TIGHTLY = "WITH STOPWAITTIME = 0.5" *)
id := MacMake('TIL ');
t := filToken(steptype,nil); (* TIL = "STEP 1 UNTIL" *)
id↑.predefined↑.marg := t;
tp := CToken(1.0,t);
t := filToken(untltype,tp);
t↑.next := nil;
end;
(* allocation routines: getLine, relLine *)
function getLine(length: integer): linerecp;
var f,fo,fp: linerecp;
begin
if length < 10 then length := 10; (* so we don't get too fragmented *)
f := freeLines;
fo := nil;
while (f <> nil) and (f↑.length < length) do (* find a long enough free line *)
begin fo := f; f := f↑.next end;
if f <> nil then
begin
if f↑.length < (length + 8) then
begin (* use entire free line *)
if fo = nil then freeLines := f↑.next (* splice out old free line *)
else fo↑.next := f↑.next;
fp := f;
end
else
begin (* split free line in two parts *)
if oldLines = nil then new(fp) (* get a new line *)
else begin fp := oldLines; oldLines := fp↑.next; end;
fp↑.start := f↑.start;
fp↑.length := length;
f↑.start := f↑.start + length;
f↑.length := f↑.length - length;
end;
end
else
begin
(* *** compact screen array??? *** *)
beep; writeln(ttyoutput,'gack - no more room in listing array!!!'); beep;
(* *** do something intelligent here??? *** *)
if oldLines = nil then new(fp) (* get a new line *)
else begin fp := oldLines; oldLines := fp↑.next; end;
fp↑.start := 1; (* this will clobber line editor, but... *)
fp↑.length := length;
beep;
end;
fp↑.next := nil;
getLine := fp;
end;
procedure relLine(l: linerecp);
var f,fo: linerecp; b: boolean;
begin
if l <> nil then
if l↑.length > 0 then
begin
f := freeLines;
fo := nil;
while (f <> nil) and (f↑.start < l↑.start) do (* find where we belong in list *)
begin fo := f; f := f↑.next end;
b := true;
if fo <> nil then
with fo↑ do (* try to merge with last line *)
if (start + length) = l↑.start then
begin length := length + l↑.length; b := false end;
if f <> nil then
if (l↑.start + l↑.length) = f↑.start then (* try to merge with next line *)
if b then
begin (* merge with next line *)
f↑.start := l↑.start;
f↑.length := f↑.length + l↑.length;
b := false
end
else
begin (* can merge last & next now *)
fo↑.length := fo↑.length + f↑.length;
fo↑.next := f↑.next;
f↑.next := oldLines; (* add it to free line queue *)
oldLines := f;
end;
if b then
begin (* need to add to free line list *)
l↑.next := f;
if fo <> nil then fo↑.next := l else freeLines := l;
end
else begin l↑.next := oldLines; oldLines := l end; (* release line pntr *)
end;
end;
(* expression/line editor: exprEditor *)
(* This does not use getline or relline *)
function exprEditor(line,lstart,llength,estart: integer;
var elength: integer; off: integer): ascii;
var i,j,iCh,col,elenOld,arg: integer;
ch,sch: ascii;
b,done,insertmode,search,right,overflow: boolean;
function seek(ch: ascii): integer;
var i,j,colf: integer;
begin
seek := 0; (* assume we don't find it *)
if ch = chr(CR) then (* need to treat <cr> specially *)
if right then seek := estart + elength (* end of expression *)
else seek := estart-1 (* start of expression *)
else if right then (* see which way to seek *)
begin (* seeking for char to right *)
i := col + 1;
colf := estart + elength;
for j := 1 to arg do
begin
while (listing[i] <> ch) and (i < colf) do i := i + 1;
if i < colf then
if j < arg then i := i + 1 (* look for another *)
else seek := i; (* found it *)
end
end
else
begin (* seeking for char to left *)
i := col - 1;
for j := 1 to arg do
begin
while (listing[i] <> ch) and (estart <= i) do i := i - 1;
if estart <= i then
if j < arg then i := i - 1 (* look for another *)
else seek := i; (* found it *)
end
end
end;
procedure dchar;
var i,j: integer;
begin
for i := col + arg to llength do listing[i-arg] := listing[i];
for i := llength - arg + 1 to llength do listing[i] := ' ';
if not smartTerminal then
outLine(line,col,col,llength-col+1)
else
begin
for i := 1 to arg do delChar(line,col);
if (llength > 80) and (col <= 80) then (* deal with overflow line *)
begin
if col + arg > 81 then j := col else j := 81-arg;
for i := j to 80 do (* shift in chars from overflow line *)
outChar(line,i,listing[i],i<(estart+elength-arg));
if llength - arg >= 80 then
begin (* shift overflow line to left *)
for i := 1 to arg do delChar(line+1,1);
end
else outLine(line+1,1,81,1) (* clear overflowed line *)
end
end;
elength := elength - arg; (* update lengths *)
llength := llength - arg;
end;
begin
search := true;
right := true;
sch := chr(0); (* so ↑R does nothing til after a search/kill is done *)
if llength < estart + elength - 1 then (* consistency check *)
elength := llength - estart + 1;
elenOld := elength; (* remember initial expr length *)
for i := 1 to llength do listing[i] := listing[lstart+i-1]; (* load line *)
if llength > 80 then
begin
outLine(line+1,1,81,llength-80); (* show overflow *)
overflow := true;
end
else overflow := false;
if smartTerminal then
for i := estart to estart+elength-1 do
outChar(line,i,listing[i],true); (* print expression in bold *)
done := false;
insertmode := (elength = 0) or (off <> 0);
col := estart + off;
repeat
showCursor(line,col);
repeat ch := getChar until ch <> chr(LF); (* skip over any <lf>'s *)
iCh := ord(ch);
if iCh = ctlBslash then (* ↑\ *)
begin (* get repeat count *)
arg := 0;
ch := getChar;
while ('0' <= ch) and (ch <= '9') do
begin
arg := 10*arg + (ord(ch) - ord('0')); (* get next digit *)
ch := getChar;
end;
iCh := ord(ch);
end
else if (version = 10) and (260B <= iCh) and (iCh <= 272B) then
begin (* get repeat count -- for SAIL <cntl><digit> *)
arg := 0;
repeat
arg := 10*arg + iCh-260B; (* get next digit *)
ch := getChar;
iCh := ord(ch);
until (260B > iCh) or (iCh > 272B);
end
else arg := 1;
if (iCh <> sailundline) and
((iCh < ord(' ')) or (deletekey <= iCh)) then (* control character *)
begin
if (version = 10) and (iCh > deletekey) then (* For sail only *)
begin (* handle special SAIL bucky bits here *)
iCh := iCh - 128; (* strip off control bit *)
if (smallA <= iCh) and (iCh <= smallZ) then
iCh := iCh - ord(' '); (* convert lower to upper case *)
if iCh = ord(' ') then iCh := ctlA (* cntl-space *)
else if iCh = deletekey then
begin (* cntl-bs *)
insertmode := false;
iCh := ctlH;
end
else if iCh = TAB then
iCh := ctlE (* make ↑tab into ↑E for compatibility with SAIL line-ed *)
else if iCh = FF then iCh := ctlF (* make ↑ff into ↑F *)
else
if (ord('A') <= iCh) and (iCh < sailbackarrow) then
iCh := iCh - ord('@'); (* make into cntl-char *)
end;
if iCh = deletekey then iCh := ctlH; (* convert rubout to backspace *)
case iCh of
TAB: insertmode := true; (* ↑I *)
ctlH: begin (* backspace *)
if col - arg < estart then arg := col - estart;
col := col - arg;
if insertmode and (arg > 0) then dchar;
end;
ctlD: begin (* ↑D *)
if col + arg > estart + elength then arg := estart + elength - col;
if arg > 0 then dchar;
end;
ctlA: col := col + arg; (* ↑A *)
ctlE: col := estart + elength; (* ↑E *)
ctlF: col := estart; (* ↑F *)
ctlO: begin (* ↑O *)
j := llength + elenOld - elength; (* restore initial line length *)
if j < llength then (* fix up end of line if needed *)
begin
for i := j to llength do listing[i] := ' ';
outLine(line,j,j,llength-j+1); (* clean up the display *)
end;
llength := j;
elength := elenOld; (* restore initial expr length *)
for i := estart to llength do listing[i] := listing[lstart+i-1]; (* reload it *)
if smartTerminal then (* redisplay line *)
begin
for i := estart to estart+elength-1 do
outChar(line,i,listing[i],true); (* print expression in bold *)
outLine(line,estart+elength,estart+elength,llength-estart-elength+1);
end
else outLine(line,estart,estart,llength-estart+1);
insertmode := false;
col := estart;
end;
ESC, (* at SAIL ↑Z = 33B *)
ctlZ: begin (* ↑Z *)
col := estart; (* zero the expression *)
arg := elength;
dchar;
elength := 0;
end;
ctlR: begin (* ↑R *)
i := seek(sch); (* repeat last search/kill command *)
if i > 0 then (* if we found another of the char *)
if search then col := i (* skip to it *)
else
if right then
begin
arg := i - col;
dchar; (* kill right to char *)
end
else
begin
if col = estart + elength then col := col - 1;
arg := col - i - 1;
col := i+1;
dchar; (* kill left to char *)
col := i;
end;
end;
ctlS: begin (* ↑S *)
search := true; (* remember for ↑R command *)
right := true;
sch := getAChar; (* skip right to char next typed *)
i := seek(sch);
if i > 0 then col := i; (* skip ahead if we found one *)
end;
ctlB: begin (* ↑B *)
search := true; (* remember for ↑R command *)
right := false;
sch := getAChar; (* skip left to char next typed *)
i := seek(sch);
if i > 0 then col := i; (* skip back if we found one *)
end;
ctlT: if col > estart + 1 then (* ↑T *)
begin
ch := listing[col-1]; (* transpose last two chars *)
listing[col-1] := listing[col-2];
listing[col-2] := ch;
if smartTerminal then
begin
outChar(line,col-2,ch,true); (* and update display *)
outChar(line,col-1,listing[col-1],true);
end
else outLine(line,col-2,col-2,llength-col+1);
end;
ctlK: begin (* ↑K <vt> *)
search := false; (* remember for ↑R command *)
right := true;
sch := getAChar; (* try to find char *)
i := seek(sch);
if i > 0 then
begin
arg := i - col;
dchar; (* kill right to char *)
end
end;
ctlL: begin (* ↑L <ff> *)
search := false; (* remember for ↑R command *)
right := false;
sch := getAChar; (* try to find char *)
i := seek(sch);
if i > 0 then
begin
(* if col = estart + elength then col := col - 1; *)
arg := col - i - 1;
col := i+1;
dchar; (* kill left to char *)
col := i;
end
end;
others: done := true;
end;
if (iCh <> ctlH) and (iCh <> TAB) then insertmode := false;
end
else
begin (* ordinary character to insert *)
if insertmode then
begin
for j := llength downto col do listing[j+1] := listing[j];
listing[col] := ch; (* now insert the new character *)
elength := elength + 1; (* update lengths *)
llength := llength + 1;
if llength > 80 then
begin
if smartTerminal and not overflow then (* just overflowed *)
begin
listing[82] := ' ';
outLine(line+1,1,82,1); (* zero line *)
end;
overflow := true; (* indicate we've overflowed *)
end;
if llength > 140 then
begin (* No more room in line buffer!!! *)
beep;
if llength > 149 then
begin
llength := llength - 1;
elength := elength - 1;
if col = 150 then col := 149;
end;
end;
if smartTerminal then
begin
insChar(line,col,ch);
if (llength > 80) and (col <= 80) then
begin
insChar(line+1,1,listing[81]);
if estart+elength <= 81 then outChar(line+1,1,listing[81],false);
end;
end
else outLine(line,col,col,llength-col+1);
end
else
begin
listing[col] := ch; (* overwrite whatever was there *)
if smartTerminal then outChar(line,col,ch,true)
else outLine(line,col,col,llength-col+1);
end;
col := col + 1;
end;
if col < estart then col := estart; (* don't go before expression *)
if col >= estart + elength then (* at end of expression? *)
begin
col := estart + elength; (* don't let it get past either end *)
insertmode := true;
end;
until done;
if overflow then
begin (* restore clobbered line *)
if (line + 1 > dispHeight) or (line = dprog↑.nlines) then borderLines
else
with lines[firstDline+line]↑ do
out1Line(line+1,start,length);
end;
if llength < 150 then listing[llength+1] := ' '; (* for eGetToken *)
i := estart;
if version = 10 then
repeat (* for SAIL *)
if listing[i] = chr(sailundline) then listing[i] := '_'
else if listing[i] = chr(sailbackarrow) then
begin (* convert "←" to ":=" *)
listing[i] := ':';
llength := llength + 1;
elength := elength + 1;
i := i + 1;
for j := llength downto i do listing[j+1] := listing[j];
listing[i] := '='
end;
i := i + 1;
until i > estart + elength - 1;
curChar := estart; (* set up for parsing the expression *)
maxChar := estart + elength - 1;
endOfLine := false;
backUp := false;
expandMacros := true;
iCh := ord(ch);
if (version = 10) and (iCh > deletekey) then
begin
iCh := iCh - 128; (* strip off SAIL cntl bit *)
if (smallA <= iCh) and (iCh <= smallZ) then
iCh := iCh - ord(' '); (* convert lower to upper case *)
end
else if iCh < ord(' ') then
if iCh <> CR then iCh := iCh + ord('@'); (* convert back to ascii *)
exprEditor := chr(iCh); (* activating character *)
end;
(* page printer routines: ppGlitch,ppChar,ppOutNow,ppLine,pp5,pp10(L),pp20(L),ppInt,ppReal,ppStrng,ppDelChar,ppFlush *)
procedure ppGlitch;
var i,j: integer;
begin
if ppbufp > 0 then (* If anything in buffer *)
begin
ppLines[ppOffset] := getLine(ppBufp); (* get a line to store chars in *)
with ppLines[ppOffset]↑ do
begin
for i := 1 to ppBufp do listing[start+i-1] := ppBuf[i]; (* copy line *)
for i := ppBufp to length-1 do listing[start+i] := chr(0);
outLine(dispHeight+ppOffset+1,oppBufp+1,start+oPPbufp,ppBufp-oppBufp);
end
end
else
begin
ppLines[ppOffset] := nil;
clearLine(dispHeight+ppOffset+1);
end;
PPbufp := 0;
oPPbufp := 0;
if ppOffset >= ppSize then
begin (* need to glitch page printer *)
if ppsize < 5 then j := 1 (* determine glitch size *)
else if ppsize < 7 then j := 2
else if ppsize < 11 then j := 3
else j := 5;
for i := 1 to j do relLine(ppLines[i]);
for i := 1 to ppSize-j do ppLines[i] := ppLines[i+j];
for i := ppSize-j+1 to ppSize do ppLines[i] := nil;
if smartTerminal then delLine(dispHeight+2,j)
else
begin
for i := 1 to ppSize do
if ppLines[i] <> nil then
with ppLines[i]↑ do
outLine(dispHeight+i+1,1,start,length) (* re-draw top lines *)
else clearLine(dispHeight+i+1);
end;
ppOffset := ppOffset - j + 1;
end
else ppOffset := ppOffset + 1; (* just move to next line *)
end;
procedure ppChar(ch: ascii);
begin
if ch = chr(CR) then ppGlitch (* scroll up page printer *)
else if ch <> chr(LF) then (* flush linefeeds *)
begin (* add character to pp buffer *)
if ppBufp >= 80 then ppGlitch;
ppBufp := ppBufp + 1;
ppBuf[ppBufp] := ch;
end;
end;
procedure ppOutNow;
var i: integer;
begin
for i := oppBufp+1 to ppBufp do listing[i-oppBufp] := ppBuf[i];
outLine(dispHeight+ppOffset+1,oppBufp+1,1,ppBufp-oppBufp);
oppBufp := ppBufp;
showCursor(dispHeight+ppOffset+1,ppBufp+1);
end;
procedure ppLine; (* Does the same as ppGlitch *)
begin
ppChar(chr(CR)); (* cr *)
end;
procedure pp5(ch: c5str; length: integer);
var i: integer;
begin
for i := 1 to length do ppChar(ch[i]);
end;
procedure pp10(ch: cstring; length: integer);
var i: integer;
begin
for i := 1 to length do ppChar(ch[i]);
end;
procedure pp10L(ch: cstring; length: integer);
begin
if ppBufp > 0 then ppLine;
pp10(ch,length);
end;
procedure pp20(ch: c20str; length: integer);
var i: integer;
begin
for i := 1 to length do ppChar(ch[i]);
end;
procedure pp20L(ch: c20str; length: integer);
begin
if ppBufp > 0 then ppLine;
pp20(ch,length);
end;
procedure ppInt(i: integer);
var j: integer; n: array [1..9] of integer;
begin
for j := 1 to 9 do (* get individual digits *)
begin n[j] := i mod 10; i := i div 10 end;
j := 9;
while (j > 1) and (n[j] = 0) do j := j - 1; (* ignore leading zeros *)
for i := j downto 1 do ppChar(chr(ord('0')+n[i])); (* print it *)
end;
procedure ppReal(r: real);
var i,j: integer;
begin
j := lbufp;
putReal(r);
ppChar(' ');
for i := j+1 to lbufp do ppChar(lbuf[i]); (* print it *)
lbufp := j; (* restore old line buf pntr *)
end;
procedure ppStrng(length: integer; s: strngp);
var i,j: integer;
begin
j := 1;
for i := 1 to length do
begin
ppChar(s↑.ch[j]);
if j = 10 then begin j := 1; s := s↑.next; end
else j := j + 1;
end;
end;
procedure ppDelChar; (* for use by INTERP *)
begin
if ppBufp > 0 then
begin
ppBuf[ppBufp] := ' ';
listing[1] := ' ';
outLine(dispHeight+ppOffset+1,ppBufp,1,1);
ppBufp := ppBufp - 1;
oppBufp := ppBufp;
showCursor(dispHeight+ppOffset+1,ppBufp+1);
end;
end;
procedure ppFlush;
begin
pp20(' Will flush statemen',20); ppChar('t');
end;
(* aux routines: makeNVar, makeUVar, varLookup, flushVar, makeNewVar *)
function makeNVar(vartype: datatypes; vid: identp): varidefp;
var v,vo: varidefp; b: boolean;
begin
if curBlock = nil then v := nil else v := curBlock↑.variables;
vo := nil;
b := true;
while (v <> nil) and b do (* look through var list for free var *)
if v↑.vtype = freevartype then b := false
else begin vo := v; v := v↑.next end;
if v = nil then
begin
v := newVaridef;
with v↑ do
begin
next := nil;
if curBlock = nil then level := 0
else
begin
level := curBlock↑.level;
with curBlock↑ do numvars := numvars + 1;
end;
if vo <> nil then
begin
offset := vo↑.offset + 1;
vo↑.next := v; (* add var to current block's list of vars *)
end
else
begin
offset := 0;
if curBlock <> nil then curBlock↑.variables := v;
(* *** ??? else ??? *** *)
end;
end;
end;
with v↑ do
begin
vtype := vartype;
dtype := nil;
name := vid;
dnext := nil;
tbits := 0;
dbits := 0;
if vartype = labeltype then s := nil;
end;
makeNVar := v;
end;
function makeUVar(vartype: datatypes; vid: identp): varidefp;
var v: varidefp; sp,oldCurBlock: statementp; i: integer; b: boolean;
begin
oldCurBlock := curBlock;
curBlock := cursorStack[2].st; (* assume outermost block *)
b := true;
i := cursor; (* unless in body of an enclosing procedure *)
while i > 2 do
begin
with cursorStack[i] do
if not stmntp then
if nd↑.ntype = procdefnode then
if nd↑.body↑.stype = blocktype then
begin (* found one *)
curBlock := nd↑.body;
b := not(sParse and (i >= sCursor)); (* special case for stmnt parsing *)
i := 0
end;
i := i - 1;
end;
v := makeNVar(vartype,vid);
sp := newStatement; (* add a new declaration statement to start of block *)
with sp↑ do
begin
stype := declaretype; variables := v; numvars := 1;
next := curBlock↑.bcode;
if b then
if newDeclarations = nil then last := curBlock
else begin last := newDeclarations; newDeclarations↑.next := sp end
else begin last := curBlock; curBlock↑.bcode := sp end;
nlines := 1;
end;
if b then newDeclarations := sp;
(* fix the display up later - hopefully the variable will be defined by then *)
curBlock := oldCurBlock;
makeUVar := v;
end;
function varLookup(id: identp): varidefp;
var v: varidefp; i: integer; b: boolean;
begin
i := cursor;
b := true;
while (i > 1) and b do
begin
v := nil;
with cursorStack[i] do
if stmntp then begin if st↑.stype = blocktype then v := st↑.variables end
else if nd↑.ntype = procdefnode then v := nd↑.paramlist;
while (v <> nil) and b do
if v↑.name = id then b := false else v := v↑.next;
i := i - 1;
end;
if b then v := id↑.predefined; (* maybe it's a predefined variable? *)
varLookup := v;
end;
procedure flushVar(oldvar: varidefp);
var v,vp,vo: varidefp; j: integer; pold: pdbp;
begin
with oldvar↑ do
begin (* flush old unused variable *)
with eCurInt↑.env↑ do
if procp then j := proc↑.level else j := block↑.level;
pold := getCurInt;
setCurInt(eCurInt); (* so we use right process to access var *)
if level <= j then
killVar(getEntry(level, offset)); (* active block flush its value *)
setCurInt(pold); (* restore current process *)
vtype := freevartype;
name := nil;
if odd(tbits) then relExpr(a); (* free up old array bounds list *)
if next = nil then
begin (* last variable, so we can release it *)
v := curBlock↑.variables;
vo := nil;
while (v <> nil) and (v <> oldvar) do
begin if v↑.vtype <> freevartype then vo := v; v := v↑.next end;
if vo = nil then
begin (* no variables in block *)
v := curBlock↑.variables;
while v <> nil do begin vp := v↑.next; relVaridef(v); v := vp end;
curBlock↑.variables := nil;
curBlock↑.numvars := 0;
end
else
begin
v := vo↑.next;
vo↑.next := nil;
j := 0;
while v <> nil do
begin j := j + 1; vp := v↑.next; relVaridef(v); v := vp end;
curBlock↑.numvars := curBlock↑.numvars - j;
end
end
else tbits := 0;
end;
end;
procedure makeNewVar(newvar: varidefp);
var i,j,k: integer; env: environp; envhdr: envheaderp;
begin
envhdr := eCurInt↑.env;
while newvar↑.level < getELev(envhdr) do
envhdr := envhdr↑.parent; (* move up a level *)
if newvar↑.level = getELev(envhdr) then
begin (* active block - make a new variable *)
i := newvar↑.offset div 10; (* which environment block *)
env := envhdr↑.env[0];
if env = nil then
begin
env := newEnvironment;
env↑.next := nil;
for k := 0 to 9 do env↑.vals[k] := nil;
envhdr↑.env[0] := env;
end;
for j := 1 to i do
if env↑.next <> nil then env := env↑.next
else
begin
env↑.next := newEnvironment;
env := env↑.next;
env↑.next := nil;
for k := 0 to 9 do env↑.vals[k] := nil;
if j < 5 then envhdr↑.env[j] := env;
end;
j := newvar↑.offset mod 10; (* entry in environment block *)
env↑.vals[j] := newEentry; (* get environment entry for the variable *)
with env↑.vals[j]↑ do
begin
etype := newvar↑.vtype; (* copy datatype of variable *)
if etype = rottype then etype := transtype; (* rots are transes internally *)
end;
makeVar(env↑.vals[j],newvar,newvar↑.tbits);
end;
end;
(* basic read routines: readPPLine, readLine & errprnt *)
procedure readPPLine(off: integer);
var ch: ascii; i,j: integer;
begin
if ppOffset >= ppSize then
begin
ch := listing[1];
ppGlitch; (* so line has room to overflow *)
ppOffset := ppOffset - 1;
listing[1] := ch;
end;
j := dispHeight+ppOffset+1;
if (off = 0) or not smartTerminal then
outline(j,1,1,1); (* put out prompt or echo *)
i := off;
ch := exprEditor(j,1,1,2-off,i,off);
if smartTerminal then (* deboldify it *)
out1Line(j,1,maxchar);
for i := 1 to maxChar do ppBuf[i] := listing[i];
ppBufp := maxChar;
oppBufp := maxChar;
ppLine;
listing[1] := ppBuf[1]; (* fix things up for getToken *)
listing[maxChar+1] := ' ';
end;
procedure readline;
var i: integer;
procedure rdLine(var fi: atext);
var ch: ascii; i,j: integer;
procedure addit(c: c4str);
var i: integer;
begin
if c[1] = ' ' then
begin
for i := 1 to 4 do listing[maxchar+i-1] := c[i];
ch := ' ';
maxchar := maxchar + 4;
end
else
begin
listing[maxchar] := c[1];
ch := c[2];
maxchar := maxchar + 1;
end;
end;
begin
maxchar := 0;
curchar := 1;
if eofError or eof(fi) then
begin
if filedepth >= 1 then
begin (* continue with last file *)
filedepth := filedepth - 1;(* pop up a level *)
ppLine; (* give luser a sense of progress *)
readline; (* try again with popped file *)
end
else
begin (* yow - no file left - complain *)
pp20L('*** End of File enco',20); pp20L('untered while parsin',20);
pp10('g program ',10); ppLine;
eofError := true;
listing[1] := 'E'; (* force parser to give up *)
listing[2] := 'N';
listing[3] := 'D';
listing[4] := ';';
listing[5] := ' ';
maxchar := 5;
end
end
else
begin (* normal case - read in next line *)
if ord(fi↑) = CR then get(fi); (* readln *)
while (ord(fi↑) = CR) or (ord(fi↑) = LF) or (ord(fi↑) = 0) do
begin
if ord(fi↑) = CR then curFLine := curFLine + 1; (* count blank lines too *)
get(fi);
end;
if ord(fi↑) <> FF then curFLine := curFLine + 1
else (* new page *)
begin
get(fi); (* skip past page mark (= ff) *)
curPage := curPage + 1;
ppInt(curpage); (* give luser a sense of progress *)
ppChar(' ');
ppOutNow;
curFLine := 1;
end;
if version = 10 then
begin (* for SAIL we have to use the following to get full ASCII character set *)
while not eof(fi) and not (ord(fi↑)=15B) and (maxchar < 129) do
begin
ch := fi↑;
if not ((ord(ch) = 12B) or (ord(ch) = 0)) then (* ignore linefeeds & nulls *)
begin
maxchar := maxchar + 1;
case ord(ch) of (* so we can use some of the extra characters on SAIL *)
137B: addit(':= '); (* "←" → ":=" *)
034B: addit('<= '); (* "≤" → "<=" *)
035B: addit('>= '); (* "≥" → ">=" *)
033B: addit('<> '); (* "≠" → "<>" *)
031B: addit('-> '); (* "→" → "->" *)
004B: addit(' and'); (* "∧" → " and " *)
005B: addit(' not'); (* "¬" → " not " *)
037B: addit(' or '); (* "∨" → " or " *)
036B: addit(' eqv'); (* "≡" → " eqv " *)
026B: ch := '#'; (* "⊗" → "#" *)
007B: addit(' pi '); (* "π" → " pi " *)
020B, (* "⊂" → "\" so we can read old AL macro delimiters *)
021B: ch := '\'; (* "⊃" → "\" *)
030B: ch := '_'; (* "_" → "_" because Pascal on SAIL's so dumb *)
others: begin end; (* nothing to do *)
end;
if ord(ch) <> TAB then listing[maxchar] := ch
else
begin (* turn tabs into spaces *)
i := 8*(((maxchar - 1) div 8) + 1);
for j := maxchar to i do listing[j] := ' ';
maxchar := i;
end;
end;
get(fi);
end;
end
else
begin (* for OMSI we can just use the following *)
(* if eoln(fi) then readln(fi); *** *)
(* while not eoln(fi) and (maxchar < 129) do *** *)
begin
maxchar := maxchar + 1;
(* read(fi,listing[maxchar]); *** *)
if ord(listing[maxchar]) = TAB then (* turn tabs into spaces *)
begin
i := 8*(((maxchar - 1) div 8) + 1);
for j := maxchar to i do listing[j] := ' ';
maxchar := i;
end;
end;
end;
listing[maxchar+1] := ' '; (* always can count on a final blank *)
end;
end;
begin
case filedepth of
0: begin
if sParse then
begin
listing[1] := '*'; (* prompt for more input *)
readPPLine(0);
listing[1] := ' '; (* so getToken ignores prompt char *)
end
else
begin
pp20('End of File encounte',20); pp20('red while reading in',20);
pp10(' program. ',9); ppLine;
endOfLine := true;
maxChar := 0;
curchar := 1;
end
end;
1: rdline(file1);
2: rdline(file2);
3: rdline(file3);
4: rdline(file4);
5: rdline(file5);
end;
shownLine := false;
end;
procedure errprnt;
var i: integer; s: strngp;
begin
errcount := errcount + 1; (* keep track of how many errors we've reported *)
ppLine;
if fparse then
begin
if (not (sParse or shownline)) and
((filedepth > 0) or (macrodepth > 0)) then
begin (* tell where error occured *)
ppChar('p'); ppInt(curPage); pp5(', l ',3); ppInt(curFLine);
if macrodepth > 0 then
begin
pp20(' while expanding mac',20); pp5('ro: ',4);
with curmacstack[macrodepth]↑.name↑ do
ppStrng(length,name);
end;
ppLine;
for i := 1 to maxchar do ppChar(listing[i]); (* show line *)
ppLine;
shownline := true;
end;
for i := 1 to curchar-1 do ppChar(' '); (* show where in line *)
ppChar('↑'); ppLine;
end;
end;
(* getToken *)
function copyToken: tokenp; (* aux function used by getToken & elsewhere *)
var t: tokenp;
begin
t := newToken; (* get a new token *)
with curToken do (* copy the token's fields from curToken *)
begin
t↑.next := next;
t↑.ttype := ttype;
if ttype = constype then t↑.cons := copyExpr(cons,true)
else
begin
t↑.rtype := rtype;
t↑.len := len; (* this should work ... *)
t↑.str := str;
end;
end;
copyToken := t;
end;
procedure getToken;
var b,bp: boolean; v,vp: varidefp; t,tp: tokenp; n: nodep;
i,j,l: integer; r,rf: real; sp: statementp;
ch,chp: ascii; res: reswordp; id: identp; st: strngp;
procedure addChar(ch: ascii; var s: strngp; var j: integer);
begin
if j < 10 then j := j + 1
else begin j := 1; s↑.next := newStrng; s := s↑.next; s↑.next := nil end;
s↑.ch[j] := ch;
end;
procedure upToken(t: tokenp);
begin
if t <> nil then
with t↑ do (* copy the token's fields into curToken *)
begin
curToken.next := next;
curToken.ttype := ttype;
if ttype = constype then curToken.cons := copyExpr(cons,true)
else
begin
curToken.rtype := rtype;
curToken.len := len; (* this should work ... *)
curToken.str := str;
end;
end;
end;
begin
if backup and flushcomments and (curToken.ttype = comnttype) then
begin (* flush any comments we weren't ever supposed to see *)
backup := false;
freStrng(curToken.str);
end;
if backup then backup := false (* use current token *)
else if macrodepth > 0 then
begin (* get next token in macro *)
if curToken.next = nil then
begin (* end of current macro - pop up a level *)
v := curmacstack[macrodepth]; (* definition for current macro *)
if v <> nil then
if v↑.vtype = mactype then v := v↑.mdef↑.mpars (* args for macro *)
else v := nil; (* no args *)
while v <> nil do (* need to release old tokens *)
begin
t := v↑.marg;
while t <> nil do begin tp := t↑.next; relToken(t); t := tp end;
v := v↑.next;
end;
curToken.next := macrostack[macrodepth]; (* pop old token *)
macrodepth := macrodepth - 1;
getToken; (* try again *)
end
else upToken(curToken.next); (* otherwise just copy the next token *)
end
else if (curChar > maxChar) and not fParse then
begin (* that's it - end of line *)
with curToken do
begin
ttype := delimtype;
ch := chr(CR);
end;
endOfLine := true;
end
else
begin (* scan line for next token *)
if curChar > maxChar then readline;
while not endOfLine and
((listing[curchar] = ' ') or (listing[curchar] = chr(TAB))) do (* skip blanks *)
if curchar < maxchar then curchar := curchar + 1
else if fParse then readline else endOfLine := true;
ch := listing[curchar]; (* first char of next token *)
if (('A' <= ch) and (ch <= 'Z')) or (ch = chr(undline)) or (* A..Z,_ *)
((chr(smallA) <= ch) and (ch <= chr(smallZ))) then (* a..z *)
begin (* identifier or reserved word *)
l := curchar;
repeat
l := l + 1;
ch := listing[l];
until not ((('0' <= ch) and (ch <= '9')) or (('A' <= ch) and (ch <= 'Z'))
or ((chr(smallA) <= ch) and (ch <= chr(smallZ))) or (ch = chr(undline)));
l := l - curchar; (* length of string *)
res := resLookup(curchar,l);
if res <> nil then
begin
with curToken do (* it's a reserved word *)
begin
ttype := reswdtype;
rtype := res↑.rtype;
stmnt := res↑.stmnt; (* copy whatever type it really is *)
end; (* all fields are same length here *)
if (res↑.rtype = stmnttype) and (res↑.stmnt = commenttype) then
begin (* read comment *)
if not flushcomments then
begin
curToken.ttype := comnttype;
st := newStrng;
st↑.next := nil;
curToken.str := st;
j := 0;
l := 0;
end;
repeat
ch := listing[curchar];
if not flushcomments then
begin
addChar(ch,st,j);
l := l + 1;
end;
if (curchar < maxchar) or (ch = ';') then curchar := curchar + 1
else if fParse then
begin
readLine;
if not flushcomments then
begin
addChar(chr(15B),st,j); (* append a crlf *)
addChar(chr(12B),st,j);
l := l + 2;
end
end
else
begin
endOfLine := true;
if not flushcomments then
begin
addChar(';',st,j); (* end the comment *)
l := l + 1;
end;
end;
until endOfLine or eofError or (ch = ';');
curToken.len := l;
if eofError then
begin
pp20L('*** while searching',20); pp20(' for end of comment ',19);
ppLine;
end;
if flushcomments then getToken; (* return a real token *)
end
else curchar := curchar + l;
end
else
begin
curToken.ttype := identtype; (* it's an identifier then *)
id := idLookup(curchar,l); (* see if it's already been defined *)
if id = nil then (* need to define it *)
begin
id := newIdent;
st := newStrng;
st↑.next := nil;
with id↑ do
begin
name := st;
length := l;
predefined := nil;
i := hash(listing[curchar]); (* find proper bucket *)
next := idents[i]; (* link us onto list of identifiers *)
idents[i] := id;
end;
j := 0; (* now make a copy of the identifier's name *)
for i := curchar to curchar + l - 1 do
addChar(uppercase(listing[i]),st,j);
for i := j + 1 to 10 do st↑.ch[i] := ' '; (* for completeness... *)
end;
curchar := curchar + l;
if (listing[curchar] <> ':') or (listing[curchar+1] = '=') then
curToken.id := id (* we'll worry if it's a variable or constant later *)
else
begin (* looks like it's a label *)
curchar := curchar + 1; (* skip over the ':' *)
v := varLookup(id);
if v = nil then
begin (* undeclared label - be nice *)
pp20L(' Undeclared identifi',20); pp20('er defined to be a l',20);
pp5('abel.',5); errprnt;
v := makeUVar(labeltype,id);
v↑.s := nil;
end
else if v↑.vtype <> labeltype then
begin (* same name as existing variable *)
pp20L(' Previously defined ',20); pp20('variable used as a l',20);
pp10('abel name.',10); errprnt;
end
else if v↑.s <> nil then (* multiply defined label *)
begin
pp20L(' Multiply defined la',20); pp5('bel. ',4); errprnt;
end;
if (v↑.vtype = labeltype) and (v↑.s = nil) then
begin (* it's a good label *)
curToken.ttype := labeldeftype;
curToken.lab := v;
end
else getToken; (* bad - ignore it & get a good token *)
end
end
end
else if (('0' <= ch) and (ch <= '9')) (* number *)
or ((ch = '.') and
('0'<= listing[curchar+1]) and (listing[curchar+1] <= '9')) then
begin
r := 0;
while ('0' <= ch) and (ch <= '9') do
begin
r := 10 * r + (ord(ch) - ord('0'));
curchar := curchar + 1;
ch := listing[curchar];
end;
if ch = '.' then (* read in fraction part *)
begin
curchar := curchar + 1; (* skip over '.' *)
ch := listing[curchar];
rf := 1;
while ('0' <= ch) and (ch <= '9') do
begin
rf := rf * 10.0;
r := r + (ord(ch) - ord('0')) / rf;
curchar := curchar + 1;
ch := listing[curchar];
end;
end;
n := newNode;
n↑.ntype := leafnode;
n↑.ltype := svaltype;
n↑.s := r;
curToken.ttype := constype;
curToken.cons := n;
end
else if ch = '"' then (* string *)
begin
st := newStrng;
st↑.next := nil;
n := newNode;
n↑.ntype := leafnode;
n↑.ltype := strngtype;
n↑.str := st;
curToken.ttype := constype;
curToken.cons := n;
l := 0;
j := 0;
repeat
if curchar < maxchar then
begin
curchar := curchar + 1;
ch := listing[curchar];
b := (ch = '"');
if b and (curchar < maxchar) then
if listing[curchar+1] = '"' then
begin curchar := curchar + 1; b := false end;
if not b then
begin
addChar(ch,st,j);
l := l + 1;
end;
end
else
begin
b := true;
pp20L('Adding missing quote',20); errPrnt;
if not fparse then endOfLine := true;
addChar('"',st,j); (* end the string *)
l := l + 1;
end;
until b;
n↑.length := l;
curchar := curchar + 1;
end
else if (ch = chr(lbrace)) or
(((ch = '(') or (ch = '/')) and (listing[curchar+1] = '*')) then
begin (* it's a comment *)
if not flushcomments then
begin
curToken.ttype := comnttype;
st := newStrng;
st↑.next := nil;
curToken.str := st;
end;
j := 0;
l := 0;
repeat
ch := listing[curchar];
if not flushcomments then
begin
addChar(ch,st,j);
l := l + 1;
end;
b := ch=chr(rbrace);
if ((ch=')') or (ch='/')) and (1 < curchar) then
b := listing[curchar-1]='*';
if (curchar < maxchar) or b then curchar := curchar + 1
else if fParse then
begin
readLine;
if not flushcomments then
begin
addChar(chr(CR),st,j); (* append a crlf *)
addChar(chr(LF),st,j);
l := l + 2;
end;
end
else
begin
endOfLine := true;
if not flushcomments then
begin
addChar('*',st,j); (* end the comment *)
addChar(')',st,j);
l := l + 2;
end;
end;
until endOfLine or eofError or b;
curToken.len := l;
if eofError then
begin
pp20L('*** while searching',20); pp20(' for end of comment ',19);
ppLine;
end
else if flushcomments then getToken; (* return a real token *)
end
else (* delimiter or operator *)
begin
chp := listing[curchar+1];
if ((ch = ':') and (chp = '=')) or (* := *)
((ch = '-') and (chp = '>')) or (* -> *)
(((ch = '<') or (ch = '>')) and (chp = '=')) or (* <= >= *)
((ch = '=') and ((chp = '<') or (chp = '>'))) or (* =< => *)
((ch = '<') and (chp = '>')) then l := 2 (* <> *)
else l := 1;
res := resLookup(curchar,l);
with curToken do
if res <> nil then (* it's an operator *)
begin
ttype := reswdtype;
rtype := res↑.rtype;
op := res↑.op;
end
else (* it's a delimiter *)
begin
ttype := delimtype;
if endOfLine then ch := chr(CR) else ch := listing[curchar];
end;
curchar := curchar + l;
end;
end;
b := expandmacros;
while b and ((curToken.ttype = identtype) or (curToken.ttype = macpartype)) do
begin (* see if we need to expand a macro *)
with curToken do
if ttype = identtype then v := varLookup(id) else v := mpar;
if v = nil then b := false
else if v↑.vtype = macargtype then
begin
macrodepth := macrodepth + 1;
macrostack[macrodepth] := curToken.next; (* push current token *)
curmacstack[macrodepth] := v; (* no arguments here *)
upToken(v↑.marg); (* actual macro arg *)
end
else if v↑.vtype = mactype then
begin
vp := v↑.mdef↑.mpars; (* get parameter list *)
if vp <> nil then (* bind macro parameters *)
begin
getToken; (* look for opening '(' *)
if (curToken.ttype <> delimtype) or (curToken.ch <> '(') then
begin (* didn't find opening '(' *)
backup := true;
pp20L(' *** Macro arguments',20); pp20(' missing opening "("',20);
pp20(' - good luck! ',13); errprnt;
end;
while vp <> nil do
begin
getToken; (* see if it's a simple or \...\ arg *)
if (curToken.ttype = delimtype) and (curToken.ch = '\') then
begin
t := nil;
repeat
getToken; (* scan the argument *)
bp := (curToken.ttype = delimtype) and (curToken.ch = '\');
if not bp then
if t = nil then begin t := copyToken; tp := t end
else begin tp↑.next := copyToken; tp := tp↑.next end;
until bp;
end
else t := copyToken;
vp↑.marg := t;
vp := vp↑.next;
getToken; (* now get separating ',' or closing ')' *)
if vp <> nil then (* look for separating comma *)
if (curToken.ttype <> delimtype) or (curToken.ch <> ',') then
begin
backup := true;
pp20L(' *** Macro args not ',20); pp20('separated by "," - g',20);
pp10('ood luck! ',9); errprnt;
end;
end;
if (curToken.ttype <> delimtype) or (curToken.ch <> ')') then
begin
backup := true; (* back up so we'll reparse last token *)
pp20L(' *** Macro arguments',20); pp20(' missing closing ")"',20);
pp20(' - good luck! ',13); errprnt;
end;
end;
macrodepth := macrodepth + 1;
macrostack[macrodepth] := curToken.next; (* push current token *)
curmacstack[macrodepth] := v; (* save pointer to macro name *)
upToken(v↑.mdef↑.macdef); (* expand macro *)
end
else b := false;
end;
if fParse and eofError then endOfLine := true;
end;
(* initialization routines: initEditor & initOuterBlock *)
procedure initEditor;
var i: integer;
begin
for i := 1 to listinglength do listing[i] := ' ';
for i := 1 to 160 do lbuf[i] := ' ';
for i := 1 to maxLines do lines[i] := nil;
for i := 1 to 10 do cursorStack[i].st := nil;
lbufp := 0;
cursor := 0;
new(freeLines);
with freeLines↑ do
begin next := nil; start := 191; length := listinglength - 190 end;
oldLines := nil;
for i := 1 to maxPPLines do ppLines[i] := nil; (* init page printer *)
ppBufp := 0;
oppBufp := 0;
ppOffset := 1;
ppSize := 3;
screenheight := initScreen(listing);
dispHeight := screenHeight - 5; (* header + trailer lines + page printer *)
smartTerminal := screenheight < 30; (* for now *)
newDeclarations := nil;
flushcomments := true;
backup := false;
fParse := false;
sParse := false;
macrodepth := 0;
expandmacros := true;
filedepth := 0;
curline := 0;
curpage := 1;
eofError := false;
curToken.next := nil;
flushcomments := true;
checkDims := false; (* assume no dimension checking *)
sysVars := nil; (* parser initialization *)
initReswords;
passConstants(xhat,yhat,zhat,nilvect,gpark,rpark,niltrans);
initIdents;
pnode := newNode;
with pnode↑ do
begin (* used to get print lists for print, prompt & abort statements *)
ntype := exprnode;
op := queryop;
end;
reInitScreen;
echo(false); (* turn off echoing *)
pp20('AL test system ',14); ppLine;
end;
procedure initOuterBlock;
var i: integer; s: statementp; envhdr: envheaderp;
begin
flushOldEnvironments(0);
eCurInt := getCurInt;
debugPdbs[0] := eCurInt;
with eCurInt↑ do
begin
spc := dprog;
sdef := dprog;
linenum := 2;
end;
pcLine := 2;
s := dprog↑.pcode↑.bcode;
s↑.bpt := true; (* just deal with the BEGIN *)
Interp(0); (* Initialize outermost block *)
s↑.bpt := false; (* done with bpt now *)
while s↑.stype <> endtype do s := s↑.next; (* find block END *)
s↑.bpt := true; (* so we'll never flush outer block's variables *)
if eCurInt↑.env↑.parent = nil then (* = sysEnv *)
begin
envhdr := newEheader;
with envhdr↑ do
begin
parent := eCurInt↑.env;
block := dprog↑.pcode;
procp := false;
for i := 0 to 4 do env[i] := nil;
varcnt := 0;
end;
with eCurInt↑ do
begin
level := 1;
env := envhdr;
end;
end;
end;
(* print routines: putChar, put5, put10, putLine *)
procedure putChar(ch: ascii);
var i: integer; l: linerecp;
begin
if ch = chr(CR) then
begin (* write out the line *)
if lbufp > 160 then lbufp := 160; (* in case there was an overflow *)
if outFilep then
begin (* send line out to file *)
for i := 1 to lbufp do begin outFile↑ := lbuf[i]; put(outFile) end;
outFile↑ := chr(CR); put(outFile); (* don't forget the crlf *)
outFile↑ := chr(LF); put(outFile);
end
else
if (firstLine <= curLine) and (curLine <= lastLine) then
if not (setup or dontPrint or fParse) then
begin
l := getLine(lbufp); (* get a line to store chars in *)
for i := 1 to lbufp do listing[l↑.start+i-1] := lbuf[i]; (* copy line *)
for i := lbufp to l↑.length-1 do listing[l↑.start+i] := chr(0);
i := curLine - topDline + 1; (* index into lines array *)
if lines[i] <> nil then relLine(lines[i]);
lines[i] := l; (* add to display list *)
i := i - firstDline + 1; (* where it goes on screen *)
if (0 < i) and (i <= dispHeight) then
out1Line(i,l↑.start,lbufp); (* & display it *)
end;
curLine := curLine + 1;
lbufp := 0;
end
else if ch <> chr(LF) then (* flush linefeeds *)
begin (* add character to line buffer *)
lbufp := lbufp + 1;
if lbufp > 160 then
begin
if lbufp = 161 then
begin pp20L('Line buffer overflow',20); ppLine; end
end
else if ch = '_' then lbuf[lbufp] := chr(sailundline) (* so prints right on SAIL *)
else lbuf[lbufp] := ch;
end;
end;
procedure put5(ch: c5str; length: integer);
var i: integer;
begin
for i := 1 to length do putChar(ch[i]);
end;
procedure put10(ch: cstring; length: integer);
var i: integer;
begin
for i := 1 to length do putChar(ch[i]);
end;
procedure putLine;
begin
putChar(chr(CR)); (* cr *)
end;
(* aux print routines: putReal, putInt, putVec, putTrans, putStrng, putTlist *)
procedure putReal (* s: real *);
var i,j,si,expo: integer; sf: real;
begin
if s < 0 then begin putchar('-'); s := -s end;
if s < 1E-20 then begin expo := 0; s := 0 end
else
begin
expo := trunc(ln(s)/ln(10.0)); (* how big is s? *)
s := s / exp(expo * ln(10)); (* normalize it between 1.0 & 9.999... *)
s := s + 0.0000005; (* round it off too *)
end;
sf := 0.000001;
i := 0;
while (expo >= 0) and (i < 7) do
begin
si := trunc(s); (* get next digit *)
putchar(chr(ord('0') + si));
s := 10.0 * (s - si);
sf := 10 * sf;
expo := expo - 1;
i := i + 1;
end;
if expo > 0 then
begin
for j := 1 to expo do putchar('0'); (* print trailing zeros *)
end
else
begin (* deal with fractional part *)
if i = 0 then putchar('0');
if s > sf then putchar('.');
for j := 1 to -expo-1 do putchar('0'); (* print leading zeros, if any *)
while (s > sf) and (i < 7) do
begin
si := trunc(s); (* get next digit *)
putchar(chr(ord('0') + si));
s := 10.0 * (s - si);
sf := 10 * sf;
i := i + 1;
end;
end;
end;
procedure putInt(r: real);
begin
putReal(round(r));
end;
procedure putVec(v: vectorp);
var i: integer;
begin
put10('vector( ',7);
with v↑ do
for i := 1 to 3 do
begin
putReal(val[i]);
if i = 3 then putChar(')') else putChar(',');
end;
end;
procedure putTrans(t: transp);
var i: integer; v: vectorp;
begin
with t↑ do
begin
refcnt := refcnt + 1;
put10('trans(rot(',10);
v := taxis(t); putVec(v); relVector(v);
putChar(',');
putReal(tmagn(t));
put10(' * degrees',10); put10('),vector( ',9);
for i := 1 to 3 do
begin putReal(val[i,4]); if i = 3 then putChar(')') else putChar(',') end;
put10(' * inches)',10);
refcnt := refcnt - 1;
end;
end;
procedure putStrng(length: integer; s: strngp);
var i,j: integer;
begin
j := 1;
for i := 1 to length do
begin
putchar(s↑.ch[j]);
if j = 10 then begin j := 1; s := s↑.next; end
else j := j + 1;
end;
end;
procedure putTlist(t: tokenp);
var b: boolean; i: integer; r: reswordp;
begin
while t <> nil do
begin
with t↑ do
case ttype of
reswdtype: begin
if (rtype=stmnttype) or
((rtype=filtype) and
((filler=withtype) or (filler=untltype) or (filler=viatype))) then
begin
putline;
put10(' ',10);
end
else putchar(' ');
r := findResword(t↑.rtype,ord(t↑.stmnt),0);
if r <> nil then putStrng(r↑.length,r↑.name);
end;
identtype: begin
putchar(' ');
putstrng(id↑.length,id↑.name);
end;
macpartype: begin
putchar(' ');
with mpar↑.name↑ do putstrng(length,name);
end;
constype: if cons↑.ltype = svaltype then
begin putchar(' '); putReal(cons↑.s) end
else
begin
put5(' " ',2);
putstrng(cons↑.length,cons↑.str);
putchar('"');
end;
comnttype: begin
putchar(' ');
putstrng(len,str);
end;
delimtype: putchar(ch);
end;
t := t↑.next;
end;
end;
(* expression related routines: getExprLength & putExpr *)
function getExprLength(n: nodep): integer;
var i: integer;
begin
if n = nil then i := 10
else
with n↑ do
if ntype = exprnode then i := elength
else if ntype = leafnode then
case ltype of
varitype: i := vid↑.length;
pconstype: i := cname↑.name↑.length;
svaltype: i := wid;
strngtype: i := length + 2;
vectype,
transtype: i := 99; (* who knows??? *)
end
else i := 0; (* who knows how long it is *)
getExprLength := i;
end;
procedure putexpr(n: nodep; opp: integer);
var rp, parg1, parg2: boolean; curp: integer; pn: nodep;
procedure lp;
begin
if curp < opp then begin putchar('('); rp := true end else rp := false;
end;
begin
if n = nil then put10('/* expr */',10) else
with n↑ do
begin
if ntype = leafnode then
case ltype of
svaltype: putReal(s);
vectype: putVec(v);
transtype: putTrans(t);
strngtype: begin
putchar('"');
putStrng(length,str);
putchar('"');
end;
varitype: with vid↑ do putStrng(length,name);
pconstype: with cname↑.name↑ do putStrng(length,name);
end
else (* it must be an expression node *)
begin
rp := false;
parg2 := false;
parg1 := true;
case op of
eqvop: begin curp := 1; lp; putexpr(arg1,1); parg2 := true;
put5(' eqv ',5) end;
orop,
xorop: begin curp := 2; lp; putexpr(arg1,2); parg2 := true;
if op = xorop then put5(' xor ',5)
else put5(' or ',4) end;
andop: begin curp := 3; lp; putexpr(arg1,3); parg2 := true;
put5(' and ',5) end;
sltop,
sleop,
seqop,
sgeop,
sgtop,
sneop: begin curp := 4; lp; putexpr(arg1,4); parg2 := true;
case op of
sltop: put5(' < ',3);
sleop: put5(' <= ',4);
seqop: put5(' = ',3);
sgeop: put5(' >= ',4);
sgtop: put5(' > ',3);
sneop: put5(' <> ',4);
end;
end;
saddop,
ssubop,
vaddop,
vsubop,
tvaddop,
tvsubop: begin curp := 5; lp; putexpr(arg1,5); parg2 := true;
if (op=saddop) or (op=vaddop) or (op=tvaddop) then put5(' + ',3)
else put5(' - ',3) end;
wrtop: begin curp := 6; lp; putexpr(arg1,6); parg2 := true; put5(' wrt ',5); end;
smulop,
sdivop,
maxop,
minop,
idivop,
modop,
vdotop,
svmulop,
vsmulop,
vsdivop,
crossvop,
tvmulop,
ttmulop: begin curp := 7; lp; putexpr(arg1,7); parg2 := true;
if op = vdotop then put5(' . ',3) else
if op = maxop then put5(' max ',5) else
if op = minop then put5(' min ',5) else
if op = idivop then put5(' div ',5) else
if op = modop then put5(' mod ',5) else
if (op=sdivop) or (op=vsdivop) then put5(' / ',3)
else put5(' * ',3);
end;
sexpop,
ftofop: begin curp := 8; lp; putexpr(arg1,8); parg2 := true;
if op = sexpop then put5(' ↑ ',3) else put5(' -> ',4); end;
intop: put5('int( ',4);
unitvop: put5('unit(',5);
sqrtop: put5('sqrt(',5);
expop: put5('exp( ',4);
logop: put5('log( ',4);
timeop: begin
put10('runtime ',7);
with arg1↑ do
if (ntype <> leafnode) or (ltype <> svaltype) or (s <> 0.0) then
putchar('(')
else parg1 := false;
end;
sinop: put5('sin( ',4);
cosop: put5('cos( ',4);
tanop: put5('tan( ',4);
asinop: put5('asin(',5);
acosop: put5('acos(',5);
tposop: put5('pos( ',4);
taxisop: put5('axis(',5);
specop: putchar('(');
negop, (* this and above used in dimension statement *)
tinvrtop: put5('inv( ',4);
torientop: put10('orient( ',7);
deproachop: put10('deproach( ',9);
adcop: put5('adc( ',4);
dacop,
atan2op,
vsaxwrop,
tmakeop,
fmakeop,
constrop,
vmakeop: begin parg1 := false;
if op = atan2op then put10('atan2( ',6) else
if op = vsaxwrop then put5('rot( ',4) else
if op = tmakeop then put10('trans( ',6) else
if op = fmakeop then put10('frame( ',6) else
if op = vmakeop then put10('vector( ',7) else
if op = constrop then put10('construct(',10)
else put5('dac( ',4);
putexpr(arg1,0); putchar(','); putexpr(arg2,0);
if (op=vmakeop) or (op=constrop) then
begin putchar(','); putexpr(arg3,0) end;
putchar(')');
end;
sabsop,
vmagnop,
tmagnop: begin parg1 := false; putchar(chr(vbar)); putexpr(arg1,0);
putchar(chr(vbar)) end;
inscalarop: begin parg1 := false; put10('inscalar ',8) end;
grinchop: begin parg1 := false; putchar('#') end;
snegop,
vnegop,
notop: begin parg1 := false;
if op = notop then put5(' not ',5) else put5(' - ',2);
putexpr(arg1,9)
end;
queryop,
arefop,
jointop,
macroop,
callop: begin parg1 := false;
if op = queryop then
begin put5('query',5);
if arg2 <> nil then putchar('(')
end
else begin
with arg1↑.vid↑ do putStrng(length,name);
if (op = arefop) or (op = jointop) then putchar('[')
else if arg2 <> nil then putchar('(')
end;
pn := arg2;
while pn <> nil do
begin
if op = macroop then putTlist(pn↑.tok) else putexpr(pn↑.lval,0);
pn := pn↑.next;
if pn <> nil then putchar(',');
end;
if (op = arefop) or (op = jointop) then putchar(']')
else if arg2 <> nil then putchar(')');
end;
badop: begin parg1 := false;
put10('(*bad-*) ',9);
putexpr(arg1,0);
put10('(*-bad*) ',9);
end;
end;
if parg2 then putexpr(arg2,curp)
else if parg1 then begin putexpr(arg1,0); putchar(')') end;
if rp then putchar(')');
end;
end;
end;
(* cursorStack routines: pushStmnt, pushNode, ... *)
procedure pushStmnt(s: statementp; indent: integer);
begin
cursor := cursor + 1;
with cursorStack[cursor] do
begin
cline := curLine + 1;
if cursor = 1 then ind := indent
else ind := cursorStack[cursor-1].ind + indent;
stmntp := true;
st := s;
end;
if (s↑.stlab = nil) or (cursorLine <> curLine + 1) then fieldNum := 1
else fieldNum := 0;
if s↑.stype = blocktype then curBlock := s;
end;
procedure pushNode(n: nodep);
begin
cursor := cursor + 1;
with cursorStack[cursor] do
begin
cline := curLine + 1;
if cursor = 1 then ind := 0
else ind := cursorStack[cursor-1].ind;
stmntp := false;
nd := n;
end;
fieldNum := 1;
end;
(* putStmnt: aux routines: newline, outExpr, putVars, putClause, codeLength *)
procedure putstmnt(s: statementp; indent, plevel: integer);
var i,j,k,l: integer; n,nv: nodep; st: statementp; v: varidefp; t: tokenp;
b: boolean;
procedure newline(indent: integer);
var i: integer;
begin
putline;
for i := 1 to indent do putchar(' ');
end;
procedure outExpr(n: nodep);
var i: integer;
begin
i := lbufp; (* so we can figure out how many chars expr is *)
putExpr(n,0);
if (setUp or setExpr) and (n <> nil) then
with n↑ do
begin
i := lbufp - i; (* expression length *)
if ntype = exprnode then elength := i
else if (ntype = leafnode) and (ltype = svaltype) then wid := i;
end;
end;
procedure putvars(vari: varidefp; indent: integer; b: boolean);
var vtbits,ovtbits,i: integer; n: nodep; vdt: datatypes; vdim: varidefp;
begin
vdt := nulltype;
ovtbits := 0;
vdim := nil;
i := 1;
while vari <> nil do (* print out the variable defs *)
with vari↑ do
begin
if (name <> nil) and ((vtype <> dimensiontype) and (vtype <> mactype)) then
begin
if (vtype <> vdt) or (tbits <> ovtbits) or (dtype <> vdim) then
begin
if (vdt <> nulltype) and (vdt <> proctype) then putchar(';');
if b then newline(indent)
(* else if lbufp > 60 then
begin
newline(indent);
if setCursor and (curLine = cursorLine) then fieldNum := i;
end
*) else putchar(' ');
vdt := vtype;
vtbits := tbits;
ovtbits := tbits;
vdim := dtype;
if vtbits >= 4 then
begin put10('reference ',10); vtbits := vtbits - 4 end
else if not b then put10('value ',6);
if vdim <> nil then
begin
with vdim↑.name↑ do putStrng(length,name); (* print dimension type *)
putchar(' ');
end;
case vdt of
svaltype: put10('scalar ',7);
vectype: put10('vector ',7);
rottype: put5('rot ',4);
transtype: put10('trans ',6);
frametype: put10('frame ',6);
eventtype: put10('event ',6);
strngtype: put10('string ',7);
labeltype: put10('label ',6);
cmontype: vdt := nulltype;
undeftype: begin put10('(* undefin',10); put10('ed! *) ',7); end;
end;
if vtbits = 1 then put10('array ',6)
else if vtbits = 2 then put10('procedure ',10);
end
else put5(', ',2);
if name <> nil then putStrng(name↑.length,name↑.name)
else begin put10('(* noname ',10); put5('*) ',2); end;
if odd(vtbits) and (a <> nil) then
begin
if not a↑.combnds then
begin (* print out the array bounds *)
putchar('[');
n := a↑.bounds;
while n <> nil do
begin
outExpr(n↑.lower);
putchar(':');
outExpr(n↑.upper);
n := n↑.next;
if n <> nil then putchar(',');
end;
putchar(']');
end
end
else if (vtbits = 2) and (p <> nil) then
begin
if setCursor and (curLine <= cursorLine) and
(cursorLine < curLine + p↑.body↑.nlines + 1) then
begin
pushNode(p);
cursorStack[cursor].cline := curLine;
end;
if p↑.paramlist <> nil then
begin
putchar('(');
putvars(p↑.paramlist,lbufp,false);
putchar(')');
end;
putchar(';');
putstmnt(p↑.body,indent+2,plevel);
putchar(';');
vdt := nulltype;
ovtbits := 0;
end;
end;
if b then
if vtbits = 2 then vari := nil (* only one procedure per decl stmnt *)
else vari := vari↑.dnext (* declare statement *)
else vari := vari↑.next; (* procedure parameter list *)
i := i + 1;
end;
if b and (vdt <> nulltype) then putchar(';');
end;
procedure putClause(cl: nodep);
var cnt, bits: integer; b: boolean;
begin
with cl↑ do
case ntype of
durnode: begin
put10('duration ',9);
if durrel <= sleop then put5('<= ',3)
else if durrel = seqop then put5('= ',2)
else put5('>= ',3);
outExpr(durval);
end;
velocitynode,
wobblenode,
sfacnode,
swtnode:
begin
if ntype = sfacnode then
begin put10('speed_fact',10); put5('or = ',5) end
else if ntype = wobblenode then put10('wobble = ',9)
else if ntype = velocitynode then
begin put10('velocity =',10); putChar(' ') end
else begin put10('stop_wait_',10); put10('time = ',7) end;
outExpr(clval);
end;
loadnode:begin
put10('load = ',7);
outExpr(loadval);
if loadvec <> nil then
begin
put5(' at ',4);
outExpr(loadvec);
end;
if lcsys then put10(' in world ',9)
else put10(' in hand ',8);
end;
elbownode:
begin
put5('elbow',5);
if notp then put5(' up ',3) else put5(' down',5);
end;
shouldernode:
begin
if notp then put5('right',5) else put5('left ',4);
put10(' shoulder ',9);
end;
linearnode:
begin
if notp then put10('linear ',7)
else begin put10('joint_spac',10); put5('e ',2) end;
put10('motion ',6);
end;
flipnode,
nullingnode:
begin
if notp then put5('no ',3);
if ntype = flipnode then put5('flip ',4) else put10('nulling ',7);
end;
cwnode:
begin
if notp then put10('counter_ ',8);
put10('clockwise ',9);
end;
wrtnode: begin
put10('respect to',10); putChar(' ');
outExpr(loc);
end;
apprnode,
deprnode:begin
if ntype = apprnode then put10('approach ',8)
else put10('departure ',9);
put5(' = ',3);
if loc = nil then begin put10('nildeproac',10); putchar('h') end
else outExpr(loc);
if code <> nil then
begin
put5(' then',5);
if code↑.stype = signaltype then putstmnt(code,indent+4,plevel)
else putstmnt(code↑.conclusion,indent+4,plevel);
end;
end;
wristnode:
begin
put10('force_wris',10); put5('t ',2);
if notp then put5('not ',4);
put10('zeroed ',6);
end;
ffnode: begin
put10('force_fram',10); put5('e = ',4);
outExpr(ff);
if csys then put10(' in world ',9)
else put10(' in hand ',8);
end;
forcenode:
begin
case ftype of
force: put5('force',5);
(* absforce: put10('|force| ',7); *)
absforce: begin putchar(chr(vbar)); put5('force',5);
putchar(chr(vbar)) end;
torque: put10('torque ',6);
(* abstorque: put10('|torque| ',8); *)
abstorque: begin putchar(chr(vbar)); put10('torque ',6);
putchar(chr(vbar)) end;
angvelocity: begin put10('angular_ve',10); put10('locity ',6) end;
end;
if frel <= sleop then put5(' < ',3)
else if frel = seqop then put5(' = ',3)
else put5(' >= ',4);
outExpr(fval);
if fvec <> nil then
begin
if ftype <= absforce then put10(' along ',7)
else put10(' about ',7);
outExpr(fvec);
end;
if fframe <> nil then
begin
put5(' of ',4);
outExpr(fframe↑.ff);
if fframe↑.csys then put10(' in world ',9)
else put10(' in hand ',8);
end;
end;
stiffnode:
begin
put10('stiffness ',10); put5('= ( ',3);
if (fv↑.ntype = exprnode) and (fv↑.op = vmakeop) and
(mv↑.ntype = exprnode) and (mv↑.op = vmakeop) then (* 6 scalar form *)
begin
outExpr(fv↑.arg1);
putchar(',');
outExpr(fv↑.arg2);
putchar(',');
outExpr(fv↑.arg3);
putchar(',');
outExpr(mv↑.arg1);
putchar(',');
outExpr(mv↑.arg2);
putchar(',');
outExpr(mv↑.arg3);
end
else
begin
outExpr(fv);
putchar(',');
outExpr(mv);
end;
putchar(')');
if cocff <> nil then
begin
put10(' about ',7);
outExpr(cocff↑.ff);
if cocff↑.csys then put10(' in world ',9)
else put10(' in hand ',8);
end;
end;
gathernode:
begin
put10('gather = (',10);
bits := gbits;
cnt := 0;
while bits <> 0 do
begin
b := false;
if odd(bits) then
if cnt = 12 then put5('tbl ',3)
else
begin
if cnt >= 6 then
begin
putchar('t');
putchar(chr(ord('1') + cnt - 6));
end
else
begin
if cnt <= 2 then putchar('f') else putchar('m');
putchar(chr(ord('x') + cnt mod 3));
end;
b := true;
end;
bits := bits div 2;
cnt := cnt + 1;
if b and (bits <> 0) then putchar(',');
end;
putchar(')');
end;
end;
end;
function codeLength(st: statementp): integer;
begin
if st↑.stype = signaltype then codeLength := 1
else codeLength := st↑.conclusion↑.nlines;
end;
(* putStmnt: main body *)
begin
plevel := plevel - 1;
if s = nil then (* actually should never get here *)
if (firstLine <= curLine) and (curLine < lastLine) then
begin
newLine(indent);
put10('/* stmnt *',10); putChar('/');
end
else curLine := curLine + 1
else if (s↑.stype = aborttype) and (s↑.debugLev > 0) then
begin (* do nothing *) end
else if plevel = 0 then
begin
if (firstLine <= curLine) and (curLine <= lastLine) then put5(' ... ',4);
curLine := curLine + s↑.nlines;
end
else if setup or (findStmnt <> nil) or
(setCursor and
(curLine < cursorLine) and (cursorLine <= curLine + s↑.nlines)) or
((firstLine <= curLine + 1) and (curLine < lastLine)) or
((curLine < firstLine) and (firstLine <= curLine + s↑.nlines)) then
with s↑ do
begin
l := curLine; (* remember current line for set up *)
if setCursor and
(curLine < cursorLine) and (cursorLine <= curLine + nlines) then
begin
if stype = progtype then begin cursor := 0; i := 1 end
else i := indent-cursorStack[cursor].ind;
pushStmnt(s,i);
end;
if stlab <> nil then (* if there's a label print it first *)
begin
putLine;
with stlab↑.name↑ do putStrng(length,name);
putchar(':')
end;
if findStmnt <> nil then
if s = findStmnt then
begin findLine := curLine + 1; findStmnt := nil end;
if (sParse or (curLine > 0)) and (stype <> declaretype) then newLine(indent);
if bad then lbuf[1] := '!'; (* mark it as bad *)
case stype of
progtype: begin
l := 1;
putChar(' ');
putStmnt(pcode,1,plevel+1);
putLine; (* put out last line *)
end;
blocktype: begin
if curLine = 0 then
begin
curLine := 1;
cursorStack[2].cline := 1;
end;
put10('begin ',6);
if blkid <> nil then
begin putChar('"');
putStrng(blkid↑.length,blkid↑.name);
putChar('"') end;
if plevel = 1 then
begin
newline(indent+2);
put5('... ',3);
st := bcode;
while st↑.stype <> endtype do st := st↑.next; (* find end *)
putstmnt(st,indent,plevel); (* and print it *)
end
else
begin
st := bcode;
repeat (* print statements in block *)
putstmnt(st,indent,plevel);
if (st↑.stype <> commenttype) and
(st↑.stype <> endtype) and
(st↑.stype <> declaretype) then putchar(';');
st := st↑.next;
until st = nil;
end;
end;
coendtype,
endtype: begin
if stype = endtype then put5('end ',4)
else put10('coend ',6);
if blkid <> nil then
begin putChar('"');
putStrng(blkid↑.length,blkid↑.name);
putchar('"') end;
end;
declaretype: begin
putvars(variables,indent,true);
end;
coblocktype: begin
put10('cobegin ',8);
if cblkid <> nil then
begin putChar('"');
putStrng(cblkid↑.length,cblkid↑.name);
putchar('"') end;
if plevel = 1 then
begin
newline(indent+2);
put5('... ',3);
end
else
begin
n := threads;
while n <> nil do (* print out the statements in block *)
begin
if setCursor then
if (curLine < cursorLine) and
(cursorLine <= curLine + n↑.cstmnt↑.nlines) then
pushNode(n);
putstmnt(n↑.cstmnt,indent+1,plevel);
if n↑.cstmnt↑.stype <> commenttype then putchar(';');
n := n↑.next;
end;
end;
putstmnt(threads↑.stmnt↑.next,indent,plevel); (* print COEND *)
end;
fortype: begin
put5('for ',4);
outExpr(forvar);
put5(' := ',4);
outExpr(initial);
put10(' step ',6);
outExpr(step);
put10(' until ',7);
outExpr(final);
put5(' do ',3);
putstmnt(fbody,indent+2,plevel);
end;
iftype: begin
put5('if ',3);
outExpr(icond);
put5(' then',5);
putstmnt(thn,indent+2,plevel);
if els <> nil then
begin
newline(indent+1);
put5('else ',4);
if setCursor and (cursorLine = curLine) then fieldNum := 2;
putstmnt(els,indent+2,plevel);
end
end;
whiletype: begin
put10('while ',6);
outExpr(cond);
put5(' do ',3);
putstmnt(body,indent+2,plevel);
end;
untiltype: begin
put5('do ',2);
putstmnt(body,indent+2,plevel);
newline(indent);
if setCursor and (cursorLine = curLine) then fieldNum := 2;
put10('until ',6);
outExpr(cond);
end;
casetype: begin
put5('case ',5);
outExpr(index);
put5(' of ',3);
newline(indent+1);
put5('begin',5);
j := indent + 2;
if setCursor and (cursorLine = curLine) then fieldNum := 2;
n := caselist;
if range >= 0 then (* unlabelled case stmnt *)
begin
if n <> nil then k := n↑.cval else k := range+1;
for i := 0 to range do
begin
if i >= k then
begin
if setCursor then
if (curLine < cursorLine) and
(cursorLine <= curLine + n↑.stmnt↑.nlines) then
pushNode(n);
putstmnt(n↑.stmnt,j,plevel);
n := n↑.next;
if n <> nil then k := n↑.cval else k := range + 1;
end;
if i <> range then putchar(';')
end
end
else
while n <> nil do (* labelled case stmnt *)
begin
if setCursor then
if (curLine < cursorLine) and
(cursorLine <= curLine + n↑.stmnt↑.nlines + 1) then
begin
with cursorStack[cursor] do
if (not stmntp) and (nd↑.ntype = clistnode) then
cursor := cursor - 1; (* if multiple labels *)
pushNode(n);
end;
newline(indent);
if n↑.cval = -1 then put5('else ',4)
else if n↑.cval = -2 then put5('[??] ',4)
else
begin putchar('['); putint(n↑.cval); putchar(']') end;
b := n↑.next <> nil; (* check for multiple labels *)
if b then b := n↑.stmnt = n↑.next↑.stmnt;
if not b then
begin
putstmnt(n↑.stmnt,j,plevel);
if n↑.next <> nil then putchar(';')
end;
n := n↑.next;
end;
putstmnt(caselist↑.stmnt↑.next,indent+1,2);
end;
calltype: begin
outExpr(what);
end;
returntype: begin
put10('return ',6);
if retval <> nil then
begin
putchar('(');
outExpr(retval);
putchar(')');
end;
end;
pausetype: begin
put10('pause ',6);
outExpr(ptime);
end;
printtype,
prompttype,
aborttype,
saytype: begin
if stype = printtype then put5('print',5)
else if stype = prompttype then put10('prompt ',6)
else if stype = aborttype then put5('abort',5)
else put5('say ',3);
n := plist;
if n <> nil then
begin
putchar('(');
if setup then
begin
outExpr(n↑.lval); (* see how long first is *)
i := lbufp + 1;
n := n↑.next;
while n <> nil do
begin
lbufp := 1; (* so we don't overflow line buffer *)
outExpr(n↑.lval); (* see how long next is *)
if i + lbufp > 78 then (* will it fit on same line? *)
begin (* no - display it on next line *)
curline := curline + 1;
i := indent + 7 + getExprLength(n↑.lval);
end
else i := i + lbufp + 1; (* length of line so far *)
n := n↑.next;
end;
end
else
begin
i := 1;
outExpr(n↑.lval);
n := n↑.next;
while n <> nil do
begin
putchar(',');
i := i + 1;
if lbufp + getExprLength(n↑.lval) > 78 then
begin (* display it on next line *)
newline(indent+6);
if setCursor and (curLine = cursorLine) then
fieldNum := i;
end;
outExpr(n↑.lval);
n := n↑.next;
end;
putchar(')');
end;
end;
end;
assigntype: begin
outExpr(what);
if aval <> nil then
begin
put5(' := ',4);
outExpr(aval);
end;
end;
signaltype,
waittype: begin
if stype = signaltype then put10('signal ',7)
else put5('wait ',5);
outExpr(event);
end;
enabletype,
disabletype: begin
if stype = enabletype then put10('enable ',7)
else put10('disable ',8);
if cmonlab <> nil then
with cmonlab↑.name↑ do putStrng(length,name);
end;
cmtype: begin
if deferCm then put10('defer on ',9)
else put5('on ',3);
with oncond↑ do
if (ntype = exprnode) or (ntype = leafnode) then outExpr(oncond)
else if ntype = arrivalnode then put10('arrival ',7)
else if ntype = departingnode then put10('departing ',9)
else if ntype = errornode then
begin
put10('error = ',8);
outExpr(eexpr);
end
else putClause(oncond);
put5(' do ',3);
putstmnt(conclusion,indent+2,plevel);
end;
affixtype: begin
put10('affix ',6);
outExpr(frame1);
put5(' to ',4);
outExpr(frame2);
if rigid then put10(' rigidly ',8)
else begin put10(' nonrigidl',10); putchar('y') end;
if byvar <> nil then begin put5(' by ',4); outExpr(byvar) end;
if atexp <> nil then
begin
if (not setup) and (lbufp + getExprLength(atexp) > 75) then
begin
newline(indent+1);
if setCursor and (curLine = cursorLine) then fieldNum := 5;
end;
put5(' at ',4);
outExpr(atexp);
if setup and (lbufp > 79) then curLine := curLine + 1;
end;
end;
unfixtype: begin
put10('unfix ',6);
outExpr(frame1);
put10(' from ',6);
outExpr(frame2);
end;
movetype,
jtmovetype,
operatetype,
opentype,
closetype,
centertype,
floattype: begin
if (stype = movetype) or (stype = jtmovetype) then put5('move ',5)
else if stype = operatetype then put10('operate ',8)
else if stype = opentype then put5('open ',5)
else if stype = closetype then put10('close ',6)
else if stype = centertype then put10('center ',7)
else put10('float ',6);
outExpr(cf);
n := clauses;
if n <> nil then
with n↑ do
if (ntype = ffnode) and pdef then n := next;
if n = nil then b := false
else b := n↑.ntype = destnode; (* print it on same line *)
if b then putchar(' ');
while n <> nil do (* print out the clauses *)
with n↑ do
begin
if not ((((ntype=viaptnode) or (ntype=byptnode)) and vlist)
or b) then
begin
if setCursor then
begin
if (ntype = viaptnode) or (ntype = byptnode) then
begin
i := 1;
nv := vclauses;
while nv <> nil do
begin i := i + 1; nv := nv↑.next end;
if vcode <> nil then i := codeLength(vcode) + i + 1;
end
else if ((ntype = deprnode) or (ntype = apprnode)) and
(code <> nil) then i := codeLength(code) + 2
else if ntype = cmonnode then i := cmon↑.nlines
else i := 1;
if (curLine < cursorLine) and
(cursorLine <= curLine + i) then
begin
pushNode(n);
cursorStack[cursor].ind := indent + 2;
end;
end;
if ntype <> cmonnode then newline(indent+2);
end;
b := false;
if ntype = destnode then
begin
put5('to ',3);
outExpr(loc);
end
else if (ntype = viaptnode) or (ntype = byptnode) then
begin
if vlist then put5(', ',2)
else if ntype = viaptnode then put5('via ',4)
else put5('by ',3);
outExpr(via);
nv := vclauses;
i := 2;
while nv <> nil do
begin
newline(indent+4);
if curLine = cursorLine then fieldNum := i;
put10('where ',6);
putClause(nv);
i := i + 1;
nv := nv↑.next;
end;
if vcode <> nil then
begin
newline(indent+4);
if curLine = cursorLine then fieldNum := i;
put5('then ',4);
if vcode↑.stype = signaltype then
putstmnt(vcode,indent+6,plevel)
else putstmnt(vcode↑.conclusion,indent+6,plevel);
end;
end
else if ntype = cmonnode then
begin
putstmnt(cmon,indent+2,plevel);
end
else if ntype = commentnode then
begin
putStrng(length,str);
end
else
begin
if (ntype <> ffnode) or (not pdef) then
begin
if ntype <> cwnode then put5('with ',5);
putClause(n);
end;
end;
n := next;
end;
end;
stoptype: begin
put5('stop ',5);
if cf <> nil then outExpr(cf);
end;
retrytype: put5('retry',5);
requiretype: begin
put10('require ',8);
if rfil then begin put10('source_fil',10); put5('e " ',3) end
else begin put10('error_mode',10); put5('s " ',3) end;
putstrng(rfilen,rfils);
putchar('"');
end;
commenttype: putStrng(len,str);
definetype: begin
put10('define ',7);
with macname↑.name↑ do putStrng(length,name);
if mpars <> nil then (* need to print macro args *)
begin
v := mpars;
putchar('(');
while v <> nil do
begin
with v↑.name↑ do putStrng(length,name);
v := v↑.next;
if v <> nil then putchar(',')
else putchar(')');
end;
end;
put5(' = \ ',4);
putTlist(macdef);
putchar('\');
end;
dimdeftype: begin
put10('dimension ',10);
with dimname↑.name↑ do putStrng(length,name);
put5(' = ',3);
outExpr(dimexpr);
end;
setbasetype: begin
put10('setbase ',8);
if cf <> nil then outExpr(cf);
end;
wristtype: begin
put10('wrist( ',6);
outExpr(fvec);
putchar(',');
outExpr(tvec);
putchar(')');
if ff <> nil then
begin
put10(' about ',7);
outExpr(ff);
end;
if ff <> arm then (* i.e. (arm <> nil) and (ff <> nil) *)
if csys then put10(' in world ',9)
else put10(' in hand ',8);
if arm <> nil then
begin
put5(' of ',4);
outExpr(arm);
end;
end;
armmagictype: begin
put10('arm_magic ',10);
outExpr(cmdnum);
put5(', ',2);
outExpr(dev);
n := iargs;
for i := 1 to 2 do
begin (* print out both arg lists *)
put5(', ( ',3);
while n <> nil do
begin
outExpr(n↑.lval);
n := n↑.next;
if n <> nil then putChar(',');
end;
putChar(')');
n := oargs;
end;
end;
emptytype: begin
put10('/* stateme',10); put5('nt */',5);
end;
(* more??? *)
end;
if setUp then nlines := curline - l; (* # of lines to print this stmnt *)
end
else
begin
if (curLine = lastLine) and (lbufp > 0) then putLine; (* put out last line *)
curLine := curLine + s↑.nlines;
end;
end;
(* cursor moving routines: nextStmnt, lastStmnt, parentStmnt *)
procedure nextStmnt(i: integer; downp: boolean); (* move down i statements *)
var j: integer; s: statementp; upp,b: boolean; n: nodep;
begin
j := 0;
b := downp;
repeat
upp := false;
with cursorStack[cursor] do
if b and stmntp then
begin (* try to move down a level *)
curLine := cline;
case st↑.stype of
blocktype: pushStmnt(st↑.bcode,2);
coblocktype: begin
pushNode(st↑.threads);
pushStmnt(st↑.threads↑.cstmnt,1);
end;
casetype: begin
curLine := curLine + 1;
n := st↑.caselist;
if st↑.range < 0 then
begin (* skip over label(s) *)
b := true;
while b and (n↑.next <> nil) do
begin
if n↑.stmnt = n↑.next↑.stmnt then
begin
curLine := curLine + 1;
n := n↑.next;
end
else b := false;
end;
end;
pushNode(n);
if st↑.range < 0 then curLine := curLine + 1;
pushStmnt(n↑.stmnt,2);
end;
fortype: pushStmnt(st↑.fbody,2);
iftype: if (fieldNum = 2) then
if st↑.els <> nil then pushStmnt(st↑.els,2) else upp := true
else pushStmnt(st↑.thn,2);
whiletype,
untiltype: pushStmnt(st↑.body,2);
cmtype: pushStmnt(st↑.conclusion,2);
others: upp := true;
end;
end
else if cursorStack[cursor-1].stmntp then
begin (* block, if, other statements *)
s := cursorStack[cursor-1].st;
if s↑.stype = blocktype then
begin (* move down to next stmnt in block *)
if st↑.next <> nil then
begin (* down to next stmnt *)
if (st↑.stype = aborttype) and (s↑.debugLev > 0) then st := st↑.next;
cline := cline + st↑.nlines;
st := st↑.next;
if (st↑.stype = declaretype) and (st↑.numvars = 1) then
with st↑.variables↑ do
if (tbits = 2) and (p <> nil) then
begin
curLine := cline;
pushNode(p);
cursorStack[cursor].cline := curLine;
end;
end
else
if cursor = 3 then j := i (* can't go any further *)
else
begin (* up we go *)
upp := true;
cursor := cursor - 1;
curBlock := s↑.bparent;
end;
end
else if b and (s↑.stype = declaretype) then
begin (* move down into procedure definition *)
curLine := cline;
pushStmnt(s↑.variables↑.p↑.body,2);
end
else if s↑.stype = iftype then
begin (* move to ELSE or next stmnt *)
if (s↑.thn = st) and (s↑.els <> nil) then
begin (* down to ELSE *)
cline := cline + st↑.nlines + 1;
st := s↑.els;
end
else
begin upp := true; cursor := cursor - 1; end; (* up we go *)
end
else if s↑.stype = casetype then
begin (* move to next stmnt *)
if stmntp then
begin upp := true; cursor := cursor - 1; end (* up we go *)
else
begin
n := nd; (* label where we are now *)
curLine := cline;
b := true;
while b and (n↑.next <> nil) do
begin
if n↑.stmnt = n↑.next↑.stmnt then
begin
curLine := curLine + 1;
n := n↑.next;
end
else b := false;
end;
nd := n;
cline := curLine;
pushStmnt(n↑.stmnt,2);
end
end
else if cursor = 2 then j := i (* can't go anywhere else *)
else
begin upp := true; cursor := cursor - 1; end; (* up we go *)
end
else
begin (* coblock, case, clause *)
with cursorStack[cursor-1].nd↑ do
if ntype = clistnode then
begin
cline := cline + stmnt↑.nlines;
cursorStack[cursor-1].cline := cline;
if next <> nil then
begin
n := next;
b := true;
while b and (n↑.next <> nil) do
begin (* check for multiple labels *)
if n↑.stmnt = n↑.next↑.stmnt then
begin
cline := cline + 1;
n := n↑.next;
end
else b := false;
end;
cursorStack[cursor-1].cline := cline;
cursorStack[cursor-1].nd := n;
st := n↑.stmnt;
if cursorStack[cursor-2].st↑.range < 0 then
cline := cline + 1; (* account for label line *)
end
else
begin
cursor := cursor - 2; (* roll back to CASE stmnt *)
curLine := cline - 1;
pushStmnt(stmnt↑.next,1); (* and move to END *)
end
end
else if ntype = colistnode then
begin
cline := cline + cstmnt↑.nlines;
cursorStack[cursor-1].cline := cline;
if next <> nil then
begin (* move down to next thread *)
st := next↑.cstmnt;
cursorStack[cursor-1].nd := next;
end
else
with cursorStack[cursor-1] do
begin (* move to COEND *)
cursor := cursor - 1;
st := cstmnt↑.next;
stmntp := true;
end;
end
else (* ??? maybe we want to descend into motion clauses ??? *)
begin upp := true; cursor := cursor - 2; end; (* up we go *)
end;
if upp then b := false
else
begin
b := downp;
j := j + 1;
end;
until j >= i;
cursorLine := cursorStack[cursor].cline;
end;
procedure lastStmnt(i: integer; downp: boolean); (* move up i statements *)
var j: integer; s: statementp; godownp,b: boolean; n: nodep;
begin
j := 0;
repeat
godownp := downp;
with cursorStack[cursor] do
begin
j := j + 1;
if st↑.stype = blocktype then curBlock := st↑.bparent;
if stmntp and (st↑.stype = iftype) and (fieldNum = 2) then
begin
curLine := cline;
pushStmnt(st↑.thn,2); (* move up to the THEN *)
end
else if cursorStack[cursor-1].stmntp then
begin
s := cursorStack[cursor-1].st;
case s↑.stype of
progtype: begin (* not much to do here *)
j := i;
godownp := false;
if st↑.stype = blocktype then curBlock := st else curBlock := nil;
end;
blocktype: begin
st := st↑.last; (* move up a statement *)
if (st↑.stype = aborttype) and (s↑.debugLev > 0) then st := st↑.last;
if (st = nil) or (st = s) then
begin (* back to BEGIN *)
cursor := cursor - 1;
godownp := false;
end
else
begin
cline := cline - st↑.nlines;
if (st↑.stype = declaretype) and (st↑.numvars = 1) then
with st↑.variables↑ do
if (tbits = 2) and (p <> nil) then
begin
curLine := cline;
pushNode(p);
cursorStack[cursor].cline := curLine;
if godownp then pushStmnt(p↑.body,2);
end;
end
end;
coblocktype:begin
n := s↑.threads;
while n↑.next <> nil do n := n↑.next; (* move to last thread *)
cursor := cursor - 1;
curLine := cline - n↑.cstmnt↑.nlines - 1;
pushNode(n);
pushStmnt(n↑.cstmnt,1);
end;
casetype: begin
if stmntp then
begin (* move to last case *)
n := s↑.caselist;
while n↑.next <> nil do n := n↑.next;
cursor := cursor - 1;
curLine := cline - n↑.stmnt↑.nlines - 1;
pushNode(n);
pushStmnt(n↑.stmnt,2);
end
else
begin (* move to previous case *)
n := nd; (* label where we are now *)
curLine := cline - 1;
b := true;
while b and (n↑.clast <> nil) do
begin
if n↑.stmnt = n↑.clast↑.stmnt then curLine := curLine - 1
else b := false;
n := n↑.clast;
end;
if n <> nil then
begin
nd := n;
curLine := curLine - n↑.stmnt↑.nlines;
cline := curLine;
pushStmnt(n↑.stmnt,2);
end
else
begin (* back to CASE stmnt *)
cursor := cursor - 1;
godownp := false;
end;
end;
end;
iftype: begin
if s↑.els = st then
begin (* back to THEN *)
st := s↑.thn;
cline := cline - s↑.thn↑.nlines - 1;
end
else
begin (* back to the IF *)
cursor := cursor - 1;
godownp := false;
end;
end;
others: begin
cursor := cursor - 1; (* up a level *)
godownp := false;
if s↑.stype = declaretype then j := j - 1; (* proc def *)
end;
end
end
else
with cursorStack[cursor-1].nd↑ do (* coblock, case, clause *)
if ntype = clistnode then
if clast <> nil then
begin
if cursorStack[cursor-2].st↑.range < 0 then
cline := cline - 1; (* account for label line *)
n := cursorStack[cursor-1].nd;
b := true;
while b and (n↑.clast <> nil) do
begin (* check for multiple labels *)
if n↑.stmnt = n↑.clast↑.stmnt then cline := cline - 1
else b := false;
n := n↑.clast;
end;
if n = nil then
begin
cursor := cursor - 2; (* up a level to CASE *)
godownp := false;
end
else
begin
cline := cline - n↑.stmnt↑.nlines;
cursorStack[cursor-1].cline := cline;
cursorStack[cursor-1].nd := n;
st := n↑.stmnt;
end
end
else
begin
cursor := cursor - 2; (* up a level to CASE *)
godownp := false;
end
else if ntype = colistnode then
if prev <> nil then
begin (* move up to last thread *)
cline := cline - prev↑.cstmnt↑.nlines;
st := prev↑.cstmnt;
cursorStack[cursor-1].cline := cline;
cursorStack[cursor-1].nd := prev;
end
else
begin
cursor := cursor - 2; (* up a level to COBEGIN *)
godownp := false;
end
else
begin (* move us up a level *)
repeat cursor := cursor - 1 until cursorStack[cursor].stmntp;
if cursor = 1 then
begin
cursor := 2; (* back to the top *)
godownp := false;
j := i;
end;
end;
end;
while godownp do (* move to bottom stmnt in current stmnt *)
with cursorStack[cursor] do
begin (* try to move down a level *)
curLine := cline;
case st↑.stype of
blocktype: begin
curLine := curLine + st↑.nlines - 2;
s := st↑.bcode;
while s↑.next <> nil do s := s↑.next;
pushStmnt(s,0); (* move to END *)
godownp := false;
end;
coblocktype: begin
curLine := curLine + st↑.nlines - 2;
pushStmnt(st↑.threads↑.cstmnt↑.next,1); (* move to COEND *)
godownp := false;
end;
casetype: begin
curLine := curLine + st↑.nlines - 2;
pushStmnt(st↑.caselist↑.stmnt↑.next,1); (* move to END *)
godownp := false;
end;
fortype: pushStmnt(st↑.fbody,2); (* move to body *)
iftype: begin
if st↑.els <> nil then
begin
curLine := curLine + st↑.thn↑.nlines + 1;
pushStmnt(st↑.els,2);
end
else pushStmnt(st↑.thn,2);
end;
whiletype,
untiltype: pushStmnt(st↑.body,2);
cmtype: pushStmnt(st↑.conclusion,2);
others: godownp := false;
end;
end;
until j >= i;
cursorLine := cursorStack[cursor].cline;
end;
procedure parentStmnt(n: integer); (* move up to n levels *)
var i,j: integer;
begin
for j := 1 to n do
begin
i := cursor - 1;
while not cursorStack[i].stmntp do i := i - 1;
if i = 1 then cursor := 2 (* back to the top *)
else cursor := i; (* back to parent *)
end;
with cursorStack[cursor] do
if st↑.stype = blocktype then curBlock := st;
cursorLine := cursorStack[cursor].cline;
end;
(* setUpStmnt,bannerLine,borderLines,redrawDisplay,adjustDisplay *)
procedure setUpStmnt;
var i: integer;
begin
lbufp := 0;
cursor := 0;
fieldNum := 1;
firstLine := 0;
lastLine := 0;
curLine := 0;
cursorLine := 1;
setCursor := false;
setUp := true;
setExpr := false;
dontPrint := false;
outFilep := false;
findStmnt := nil;
pcLine := 1;
putStmnt(dprog,0,99); (* figure out how long each statement is *)
setUp := false;
topDline := 0;
botDline := -1;
firstDline := 1;
for i := 1 to maxLines do
if lines[i] <> nil then
begin
relLine(lines[i]); (* free up any old lines *)
lines[i] := nil;
end;
for i := 1 to 20 do marks[i] := 0;
nmarks := 0;
for i := 1 to maxBpts do bpts[i] := nil;
for i := 1 to maxTBpts do tbpts[i] := nil;
nbpts := 0;
ntbpts := 0;
debugLevel := 0;
for i := 1 to 10 do debugPdbs[i] := nil;
collect := false;
singleThreadMode := false;
tSingleThreadMode := false;
setSingleThreadMode(false);
STLevel := 0;
initOuterBlock;
end;
procedure bannerLine(ch: ascii; l: integer);
var i: integer; h: packed array [1..27] of ascii;
procedure digitize(n,i:integer);
begin
listing[i] := chr((n mod 10) + ord('0')); n := n DIV 10;
if n > 0 then listing[i-1] := chr((n mod 10) + ord('0')); n := n DIV 10;
if n > 0 then listing[i-2] := chr((n mod 10) + ord('0'));
end;
begin
for i := 151 to 190 do listing[i] := ch;
h := ' Cursor at Line of ';
if l = 0 then
begin (* top line *)
for i := 11 to 20 do listing[145+i] := h[i];
digitize(topDline+firstDline-1,164);
end
else
begin (* bottom line *)
for i := 1 to 27 do listing[155+i] := h[i];
digitize(cursorline,174);
digitize(dprog↑.nlines,181);
end;
outLine(l,1,151,40);
end;
procedure borderLines;
var ch: ascii; i: integer;
begin
if not fParse then
begin
if topDline + firstDline = 2 then ch := '*' else ch := '.';
bannerLine(ch,0);
if topDline + firstDline + dispHeight - 2 >= dprog↑.nlines then ch := '*'
else ch := '.';
if botDline < dispHeight then bannerLine(ch,botDline+1)
else bannerLine(ch,dispHeight+1);
end;
end;
procedure redrawDisplay;
var i: integer;
begin
for i := 1 to dispHeight do
if lines[firstDline+i-1] <> nil then
with lines[firstDline+i-1]↑ do
out1Line(i,start,length)
else clearLine(i);
borderLines;
for i := 1 to ppSize do
if ppLines[i] <> nil then
with ppLines[i]↑ do (* redraw pp too *)
outLine(dispHeight+1+i,1,start,length)
else clearLine(dispHeight+1+i);
oppBufp := 0; ppOutNow; (* last line too *)
end;
procedure adjustDisplay;
begin
if (cursorLine < topDline + firstDline - 1) or
(cursorLine > topDline + firstDline + dispHeight - 2) then
lineNum := cursorLine - dispHeight div 2; (* off screen *)
end;
(* displayLines routine *)
procedure displayLines(var pfrom: integer);
var pto,oldDline,i,j,k: integer;
begin
if pfrom < 1 then pfrom := 1
else if pfrom+dispHeight > dprog↑.nlines then
begin
if dprog↑.nlines > dispHeight then pfrom := dprog↑.nlines-dispHeight+1
else pfrom := 1;
end;
pto := pfrom + dispHeight - 1;
if pto > dprog↑.nlines then pto := dprog↑.nlines;
if (cursorLine < pfrom) or (pto < cursorLine) then
begin (* need to move cursor *)
if cursorLine < pfrom then cursorLine := pfrom else cursorLine := pto;
setCursor := true;
end;
oldDline := firstDline; (* remember where current display starts *)
if (topDline <= pfrom) and (pfrom <= botDline) then (* roll up *)
begin
firstDline := pfrom - topDline + 1; (* new first displayed line *)
j := firstDline - oldDline; (* # & direction of lines to scroll *)
if pto <= botDline then
begin (* just need to adjust which lines we're showing *)
if smartTerminal then
begin
if abs(j) >= dispHeight then
for i := 1 to dispHeight do (* redraw them *)
with lines[firstDline+i-1]↑ do
out1Line(i,start,length)
else if j < 0 then
begin (* scroll down *)
j := -j;
delLine(dispHeight-j+1,j); (* delete last j lines *)
insLine(1,j); (* insert j new lines at top *)
for i := 1 to j do (* redraw them *)
with lines[firstDline+i-1]↑ do
out1Line(i,start,length);
end
else if j > 0 then
begin (* scroll up *)
delLine(1,j); (* delete first j lines *)
insLine(dispHeight-j+1,j); (* insert j new lines at bottom *)
for i := dispHeight-j+1 to dispHeight do (* redraw them *)
with lines[firstDline+i-1]↑ do
out1Line(i,start,length);
end
end
else
if firstDline <> oldDline then (* really anything to do? *)
for j := firstDline to firstDline + dispHeight - 1 do (* redraw screen *)
with lines[j]↑ do
out1Line(j-firstDline+1,start,length);
firstLine := 0;
lastLine := -1; (* so we won't invoke putStmnt below *)
end
else
begin (* scroll up & add new bottom lines *)
k := pto - topDline + 1 - maxLines; (* # of lines needed *)
if k > 0 then (* do we have enough? *)
begin (* make room in lines list for new lines *)
for i := 1 to k do relLine(lines[i]); (* flush old lines *)
for i := 1 to maxLines-k do lines[i] := lines[i+k]; (* shift up others *)
for i := maxLines+1-k to maxLines do lines[i] := nil; (* just to be safe *)
topDLine := topDline + k;
firstDline := pfrom - topDline + 1;
end
else k := 0;
if j <> 0 then (* j=0 when display size increases *)
if smartTerminal and (j < dispHeight) then
begin
delLine(1,j); (* delete first j lines *)
insLine(dispHeight-j+1,j); (* insert j new lines at bottom *)
for i := oldDline+dispHeight-k to botDline-topDline+1 do
with lines[i]↑ do (* & add other lines *)
out1Line(i-firstDline+1,start,length);
end
else
for i := 1 to botDline-pfrom+1 do (* redraw top lines *)
with lines[firstDline+i-1]↑ do
out1Line(i,start,length);
firstLine := botDline + 1;
lastLine := pto;
botDLine := pto;
end;
end
else if (topDline <= pto) and (pto <= botDline) then
begin (* scroll down & add new top lines *)
k := botDline - pfrom + 1 - maxLines; (* # of lines needed *)
if k > 0 then botDLine := botDline - k;
k := topDline - pfrom; (* amount to shift down *)
for i := maxLines-k+1 to maxLines do relLine(lines[i]); (* flush old lines *)
for i := maxLines downto k+1 do lines[i] := lines[i-k]; (* shift down others *)
for i := 1 to k do lines[i] := nil; (* just to be safe *)
firstDline := 1;
j := pto - topDline - oldDline + 2; (* # lines kept on display *)
if smartTerminal and (j > 0) then
begin
delLine(j+1,dispHeight-j); (* delete all but first j lines *)
insLine(1,dispHeight-j); (* & move them to bottom *)
for i := topDline-pfrom+1 to topDline+oldDline-pfrom do
with lines[i]↑ do (* & add other lines *)
out1Line(i,start,length);
end
else
for i := topDline-pfrom+1 to dispHeight do
with lines[i]↑ do (* redraw bottom lines *)
out1Line(i,start,length);
firstLine := pfrom;
lastLine := topDline - 1;
topDLine := pfrom;
end
else
begin (* need to redo entire display *)
for i := 1 to maxLines do
if lines[i] <> nil then
begin
relLine(lines[i]); (* release old lines *)
lines[i] := nil;
end;
firstLine := pfrom;
lastLine := pto;
topDLine := pfrom; (* re-draw entire display *)
botDLine := pto;
firstDline := 1;
end;
borderLines;
curLine := 0;
if firstLine <= lastLine then
putStmnt(dProg,0,99); (* write & display new lines *)
if setCursor then
begin
if (cursorLine < firstLine) or (lastLine < cursorLine) then
begin
firstLine := cursorLine;
lastLine := cursorLine;
dontPrint := true;
curLine := 0;
putStmnt(dProg,0,99); (* use putStmnt to set cursor *)
dontPrint := false;
end;
setCursor := false;
setECurInt; (* figure out what process we're pointing at *)
end;
end;
(* routines to shift display: deleteLines, insertLines, reFormatStmnt *)
procedure delUpdate(number: integer);
var i,j: integer; p: pdbp;
begin
i := 1;
while (i <= nmarks) and (marks[i] <= cursorLine) do i := i + 1;
while (i <= nmarks) and (marks[i] <= cursorLine + number) do
if i > 1 then
if marks[i-1] = cursorLine then
begin (* delete extra mark *)
nmarks := nmarks - 1;
for j := i to nmarks do marks[j] := marks[j+1];
end
else begin marks[i] := cursorLine; i := i + 1 end
else begin marks[i] := cursorLine; i := i + 1 end;
for j := i to nmarks do marks[j] := marks[j] - number;
for i := 0 to debugLevel do
begin
if i = 0 then p := getAllPdbs else p := debugPdbs[i];
while p <> nil do
with p↑ do
begin
if linenum > cursorLine then
if linenum <= cursorLine + number then linenum := cursorLine
else linenum := linenum - number;
p := nextPdb;
end;
end;
if pcline >= cursorLine then
if pcline >= cursorLine + number then pcline := cursorLine
else pcline := pcline - number;
end;
procedure deleteLines(start,number,coff: integer);
var i,j,k,dHp,odHp: integer;
begin
odHp := dprog↑.nlines;
if sParse then j := sCursor else j := 1;
for i := j to cursor - coff do (* update cursor stack *)
with cursorStack[i] do
if stmntp then st↑.nlines := st↑.nlines - number;
if not sParse then
begin
if dispHeight < odHp then odHp := dispHeight;
delUpdate(number);
end;
if not fParse then
begin
if start < topDline then
begin
number := number - (topDline - start);
start := topDline;
end;
if start + number - 1 > botDline then
number := botDline - start + 1;
j := start - topDline + 1;
for i := j to j + number - 1 do (* make sure deleted lines are released *)
relLine(lines[i]);
for i := j + number to botDline - topDLine + 1 do (* roll up *)
lines[i-number] := lines[i];
botDline := botDline - number;
for i := botDline - topDline + 2 to maxLines do lines[i] := nil;
dHp := dprog↑.nlines;
if dispHeight < dHp then dHp := dispHeight;
if start + number < topDline + firstDline then
firstDline := firstDline - number (* screen ok as is *)
else if start <= topDline + firstDline + dHp - 2 then
begin (* need to shift new lines onto screen *)
j := topDline + firstDline + dispHeight - 2 - dprog↑.nlines;
if j > 0 then (* j = # lines to add at top *)
begin (* at bottom - need to shift top down *)
if topDline + firstDline - 1 <= j then (* program length < display height *)
j := topDline + firstDline - 2; (* max # lines can add at top *)
if j > 0 then
begin (* first roll down *)
if j >= firstDline then
begin (* need to make space at top of buffer *)
k := j - firstDline + 1; (* number of new lines to add *)
for i := maxLines downto k+1 do lines[i] := lines[i-k];
for i := 1 to k do lines[i] := nil;
topDline := topDline - k;
firstDline := 1;
end
else
begin
firstDline := firstDline - j;
k := 0;
end;
number := number - j;
if smartTerminal then
begin
delLine(start-(topDline+k+firstDline-2),number+j); (* delete the lines *)
insLine(1,j); (* & insert some more at top *)
insLine(dHp-number+1,number); (* & at bottom too *)
end
else
for i := j + 1 to odHp - number do (* redraw top lines *)
with lines[firstDline+i-1]↑ do
out1Line(i,start,length);
for i := k+1 to j do
with lines[firstDline+i-1]↑ do
out1Line(i,start,length); (* redraw lines already in buffer *)
firstLine := topDline;
lastLine := topDline + k - 1;
curLine := 0;
if firstLine <= lastLine then
putStmnt(dProg,0,99); (* write & display new lines *)
start := start + j; (* correct for below *)
end;
end
else j := 0;
if number > 0 then
begin
if j <= 0 then (* make sure roll up above didn't already shift display *)
begin
j := start - (topDline + firstDline - 2);
if smartTerminal then
begin
delLine(j,number); (* delete some lines *)
insLine(dispHeight-number+1,number); (* & insert some more at bottom *)
end
else
for i := j to odHp - number do (* redraw middle lines *)
with lines[firstDline+i-1]↑ do
out1Line(i,start,length);
end;
for i := odHp - number to dHp do
if lines[firstDline+i-1] <> nil then (* already in buffer *)
with lines[firstDline+i-1]↑ do
out1Line(i,start,length); (* redraw it *)
firstLine := botDline + 1;
lastLine := topDline + firstDline + dHp - 2;
botDline := lastLine;
curLine := 0;
if firstLine <= lastLine then
putStmnt(dProg,0,99); (* write & display new lines *)
end;
if odHp < dispHeight then odHp := odHp + 1;
for i := dHp+1 to odHp do clearLine(i); (* flush any unused lines *)
end;
borderLines;
end;
end;
procedure insertLines(start,number,coff: integer); (* this one's easy *)
var i,j: integer; p: pdbp;
begin
if sParse then j := sCursor else j := 1;
if coff >= 0 then
for i := j to cursor - coff do (* update cursor stack *)
with cursorStack[i] do
if stmntp then st↑.nlines := st↑.nlines + number;
if not sParse then
begin
for i := 1 to nmarks do (* update mark table *)
if marks[i] >= cursorLine then marks[i] := marks[i] + number;
for i := 0 to debugLevel do
begin
if i = 0 then p := getAllPdbs else p := debugPdbs[i];
while p <> nil do
with p↑ do
begin
if linenum >= cursorLine then linenum := linenum + number;
p := nextPdb;
end;
end;
if pcline >= cursorLine then pcline := pcline + number;
end;
if not fParse then
begin
if start < topDline then
begin
number := number - (topDline - start);
start := topDline;
end;
if start + number > topDline + maxLines - 2 then
number := topDline + maxLines - start;
if firstDline + dispHeight - 1 + number > maxLines then
begin (* need to roll lines array up some *)
for i := 1 to number do relLine(lines[i]); (* flush top lines *)
for i := 1 to maxLines - number do lines[i] := lines[i+number]; (* roll up *)
for i := maxLines-number+1 to maxLines do lines[i] := nil;
topDline := topDline + number;
firstDline := firstDline - number;
botDline := botDline - number;
end;
for i := maxLines-number+1 to maxLines do relLine(lines[i]); (* flush buffer bottom *)
for i := maxLines - number downto start - topDline + 1 do
lines[i+number] := lines[i]; (* shift buffer down *)
for i := start - topDline + 1 to start - topDline + number do
lines[i] := nil;
botDline := botDline + number;
if botDline >= topDline + maxLines then botDline := topDline + maxLines - 1;
if start < topDline + firstDline - 1 then
firstDline := firstDline + number
else if start <= topDline + firstDline + dispHeight - 2 then
begin (* some of the insert is on screen, so adjust it *)
if topDline + firstDline + dispHeight - 1 < start + number then
begin
number := topDline + firstDline + dispHeight - 2 - start;
end;
j := start - (topDline + firstDline - 2); (* screen line to insert at *)
if smartTerminal then
begin
delLine(dispHeight-number+1,number); (* delete some lines at bottom *)
insLine(j,number); (* & insert more in middle *)
end
else
begin
for i := j to j + number - 1 do clearLine(i); (* clear inserted lines *)
for i := j + number to dispHeight do (* redraw bottom lines *)
if lines[firstDline+i-1] <> nil then
with lines[firstDline+i-1]↑ do
out1Line(i,start,length);
end;
end;
borderLines;
end;
end;
procedure reFormatStmnt(st: statementp; indent,ocur: integer);
var i,j: integer;
begin
with st↑ do
begin
curLine := 1;
setUp := true;
setCursor := false;
j := nlines; (* how long were we *)
putStmnt(st,indent,99); (* possibly reformat us *)
setUp := false;
if j <> nlines then
begin (* if necessary correct for any change in nlines *)
if j < nlines then insertLines(ocur,nlines-j,1) (* fix up screen *)
else if j > nlines then deleteLines(ocur,j-nlines,1);
end;
firstLine := cursorStack[cursor].cline;
lastLine := firstLine + nlines - 1;
end;
if firstline < topDLine then firstLine := topDline;
if botDline < lastLine then
if botDline > topDline + firstDline + dispHeight - 2 then
lastLine := botDline (* it's definitely off screen *)
else botDline := lastLine; (* should be ok.... *)
for i := firstLine - topDline + 1 to lastLine - topDline + 1 do
begin (* flush old lines before redrawing stmnt *)
relLine(lines[i]);
lines[i] := nil;
end;
setCursor := true; (* let putStmnt figure right fieldnum *)
curLine := 0;
putStmnt(dProg,0,99); (* redraw statement *)
setCursor := false;
end;
(* aux routines for parsing exprs: matchdim,getdim,dimCheck,getDelim,getDo,ppDtype *)
function matchdim(d1,d2: nodep; exactp: boolean): boolean;
var b: boolean;
begin
with d1↑ do
b := (time = d2↑.time) and (distance = d2↑.distance) and
(angle = d2↑.angle) and (dforce = d2↑.dforce);
if not (b or exactp) then
begin (* see if we can coerce d1 or d2, i.e. one is dimensionless *)
with d1↑ do
if (time = 0) and (distance = 0) and (angle = 0) and (dforce = 0) then
b := true;
if not b then (* see if d2 is dimensionless *)
with d2↑ do
if (time = 0) and (distance = 0) and (angle = 0) and (dforce = 0) then
b := true;
end;
matchdim := b;
end;
function getdim(n: nodep; var d: nodep): nodep;
var vdim: varidefp; d1: nodep;
procedure dimCopy(dp: nodep);
begin
with d↑ do
begin
time := dp↑.time;
distance := dp↑.distance;
angle := dp↑.angle;
dforce := dp↑.dforce;
end
end;
procedure dimMod(d1,d2: nodep; i: real);
begin
with d↑ do
begin
time := d1↑.time + round(i * d2↑.time);
distance := d1↑.distance + round(i * d2↑.distance);
angle := d1↑.angle + round(i * d2↑.angle);
dforce := d1↑.dforce + round(i * d2↑.dforce);
end
end;
begin (* getdim *)
if d = nil then
begin
d := newNode; (* need to make up a new dimension node to hold result *)
d↑.ntype := dimnode;
end;
if n = nil then dimCopy(nodim↑.dim)
else
with n↑ do
if (ntype = leafnode) or (ntype = procdefnode) then
begin
if ntype = procdefnode then vdim := pname
else if ltype = varitype then vdim := vari
else if ltype = pconstype then vdim := cname
else vdim := nil;
if vdim <> nil then (* see if there's an associated dimension *)
with vdim↑ do
if dtype <> nil then vdim := dtype (* yes - use it *)
else
if (vtype = transtype) or (vtype = frametype) then vdim := distancedim
else if vtype = rottype then vdim := angledim else vdim := nil;
if vdim <> nil then dimCopy(vdim↑.dim) else dimCopy(nodim↑.dim)
end
else (* see what type of expression it is *)
begin
d1 := nil;
if (op <= eqvop) or ((sinop <= op) and (op <= tanop)) or (op = sexpop) or
(op = logop) or (op = expop) or (op = unitvop) or (op = taxisop) or
(op = queryop) or (op = inscalarop) or (op = adcop) or (op = vmop) then
dimCopy(nodim↑.dim)
else if op = timeop then dimCopy(timedim↑.dim)
else if ((asinop <= op) and (op <= atan2op)) or (op = torientop) or
(op = vsaxwrop) then dimCopy(angledim↑.dim)
else if (op = constrop) or (op = fmakeop) or (op = deproachop) or
(op = grinchop) then dimCopy(distancedim↑.dim)
else if (op = tmakeop) or (op = tvmulop) or (op = ttmulop) then
d := getdim(arg2,d)
else if (op = smulop) or (op = svmulop) or (op = vsmulop) or
(op = vdotop) or (op = crossvop) then
dimMod(getdim(arg1,d),getdim(arg2,d1),1.0)
else if (op = sdivop) or (op = idivop) or (op = vsdivop) then
dimMod(getdim(arg1,d),getdim(arg2,d1),-1.0)
else if (op = sqrtop) then dimMod(nodim↑.dim,getdim(arg1,d),0.5)
else if (op = negop) then dimMod(nodim↑.dim,getdim(arg1,d),-1.0)
(* special - used by dimension statement *)
else if (op = jointop) then dimCopy(angledim↑.dim)
(* ** the above is only true for arms like the PUMA ** *)
(* ** with no prismatic joints ** *)
else d := getdim(arg1,d); (* sadd,ssub,sneg,sabs,max,min,int,mod,vmagn,
tmagn,vmake,vadd,vsub,vneg,tpos,tvadd,tvsub,
tinvrt,ftof,aref,call,bad *)
if d1 <> nil then relNode(d1);
end;
getdim := d;
end;
procedure dimCheck(n,d: nodep); (* expr n should be of dimension d *)
var dp: nodep;
begin
dp := nil;
if not matchdim(getdim(n,dp),d,checkDims) then (* does dimension match ok? *)
begin
pp20L(' Dimensions don''t ma',20); pp5('tch ',3);
errPrnt;
end;
relNode(dp);
end;
procedure getDelim(char: ascii);
begin
getToken; (* look for the char *)
with curToken do
if (ttype <> delimtype) or (ch <> char) then
begin
backup := true;
pp10L(' Need a " ',9); ppChar(char); pp10('" here. ',7);
errprnt;
end;
end;
procedure getDo;
begin
getToken;
if not endOfLine then
with curToken do
if (ttype <> reswdtype) or (rtype <> filtype) or
(filler <> dotype) then
begin
pp20L(' Need a "DO" here ',17); errprnt;
backUp := true
end;
end;
procedure ppDtype(d: datatypes);
begin
case d of
svaltype: pp10('scalar ',6);
vectype: pp10('vector ',6);
rottype: pp5('rot ',3);
transtype: pp5('trans',5);
frametype: pp5('frame',5);
eventtype: pp5('event',5);
strngtype: pp10('string ',6);
end;
end;
(* aux routines for parsing exprs: defNode,getDtype,checkarg,copyExpr *)
function defNode(d: datatypes): nodep;
var n: nodep;
begin
n := newNode;
with n↑ do
begin
ntype := leafnode;
ltype := d;
case d of
svaltype: s := 0.0;
vectype: v := nilvect;
rottype,
transtype: t := niltrans;
others: v := nil; (* this should never happen, but... *)
end;
end;
defNode := n;
end;
function getDtype(n: nodep): datatypes;
var da: datatypes;
begin
if n = nil then da := nulltype
else
with n↑ do
if ntype = leafnode then
if ltype = varitype then da := vari↑.vtype
else if ltype = pconstype then da := pcval↑.ltype
else da := ltype
else (* see what type of op we've got *)
if (svalop < op) and (op < vecop) or
(ioop < op) and (op < specop) then da := svaltype
else if (vecop < op) and (op < transop) then da := vectype
else if (transop < op) and (op < ioop) then da := transtype
else if (op = arefop) or (op = callop) then da := arg1↑.vari↑.vtype
else if (op = grinchop) then da := getDtype(arg1)
else if (op = vmop) or (op = adcop) or
(op = jointop) then da := svaltype
else if (op = badop) then da := getDtype(arg2)
else da := nulltype;
getDtype := da;
end;
function checkArg(n: nodep; d: datatypes): nodep;
var bad: nodep; da: datatypes;
begin
if n = nil then checkArg := defNode(d) (* use default value *)
else
begin
da := getdtype(n);
if (da <> d) and ((da = frametype) or (da = rottype)) then da := transtype;
if (d = da) or ((d = rottype) and (da = transtype)) then
checkArg := n (* it's fine *)
else if da = undeftype then
begin (* need to define the variable *)
if n↑.ntype = leafnode then n↑.vari↑.vtype := d
else n↑.arg1↑.vari↑.vtype := d;
checkArg := n; (* but it's fine *)
end
else
begin (* no good - need to fix things up *)
pp10L(' Found a ',9); ppDtype(da);
pp10(' where a ',9); ppDtype(d);
pp20(' should have been. ',18);
errprnt;
bad := newNode;
with bad↑ do
begin
ntype := exprnode;
op := badop;
arg1 := n;
arg2 := defNode(d);
arg3 := nil;
end;
checkArg := bad;
end;
end;
end;
function copyExpr (* (n: nodep; lcp: boolean): nodep; *);
var np: nodep;
begin
if n = nil then np := nil
else
with n↑ do
begin
if (ntype <> leafnode) or (ltype = varitype) or lcp then
begin (* need to make a copy *)
np := newNode;
np↑.ntype := ntype;
case ntype of
arraydefnode:
begin
np↑.numdims := numdims;
np↑.combnds := true; (* indicate it's a copy *)
np↑.bounds := copyexpr(bounds,false);
end;
bnddefnode:
begin
np↑.next := copyexpr(next,false);
np↑.lower := copyexpr(lower,false);
np↑.upper := copyexpr(upper,false);
end;
exprnode:
begin
np↑.op := op;
if op = arefop then lcp := true;
np↑.arg1 := copyexpr(arg1,false);
np↑.arg2 := copyexpr(arg2,lcp);
np↑.arg3 := copyexpr(arg3,false);
end;
leafnode:
begin
np↑.ltype := ltype;
np↑.length := length; (* this should work for all leaftypes *)
np↑.str := str
end;
listnode:
begin
np↑.lval := copyexpr(lval,lcp);
np↑.next := copyexpr(next,lcp);
end;
end
end
else np := n;
end;
copyExpr := np;
end;
(* aux routines for parsing expressions(cont): getArgs *)
procedure getArgs(opn: nodep);
var arg,n,np,nhdr,d: nodep; nargs,i: integer; dch: ascii; dat: datatypes;
absp,aref,func,qp,closep,b,bp: boolean; paramlist,v: varidefp;
procedure check1(d: datatypes);
begin
opn↑.arg1 := checkArg(opn↑.arg1,d); (* check datatype is right *)
end;
procedure check2(d1,d2: datatypes);
begin
with opn↑ do
begin
arg1 := checkArg(arg1,d1); (* check datatype is right for first arg *)
arg2 := checkArg(arg2,d2); (* and also check second *)
end;
end;
procedure check3(d1,d2,d3: datatypes);
begin
with opn↑ do
begin
arg1 := checkArg(arg1,d1); (* check datatype is right for first arg *)
arg2 := checkArg(arg2,d2); (* and also check second *)
arg3 := checkArg(arg3,d3); (* and also check third *)
end;
end;
begin
with opn↑ do
begin
if not ((op=arefop) or (op=callop)) then arg1 := nil;
arg2 := nil;
arg3 := nil
end;
if (opn↑.op = grinchop) then (* grinch is special *)
begin
i := cursor;
b := false;
repeat
with cursorStack[i] do
if stmntp then b := (movetype <= st↑.stype) and (st↑.stype <= floattype);
i := i - 1;
until (i = 1) or b;
if b then
opn↑.arg1 := copyExpr(cursorStack[i+1].st↑.cf,true) (* copy control frame *)
else
begin
pp20L(' Grinch can only occ',20); pp20('ur in a motion state',20);
pp5('ment.',5); errprnt;
opn↑.op := badop;
opn↑.arg1 := newNode;
opn↑.arg2 := defNode(transtype);
with opn↑.arg1↑ do
begin
ntype := exprnode;
op := grinchop;
arg1 := opn↑.arg2;
arg2 := nil;
arg3 := nil;
end
end
end
else if (opn↑.op <> inscalarop) then (* expecting some args *)
begin
i := 0;
nhdr := nil;
d := nil;
nargs := 1;
absp := false;
aref := false;
func := false;
qp := false;
closep := true;
b := true;
paramlist := nil;
case opn↑.op of
atan2op,
tmakeop,
fmakeop,
vsaxwrop,
dacop: nargs := 2;
vmakeop,
constrop: nargs := 3;
queryop: begin
qp := true;
nargs := 99; (* variable number of args *)
end;
absop: absp := true;
arefop: begin
aref := true;
with opn↑.arg1↑.vari↑ do (* check it's defined *)
if odd(tbits) then n := a else n := nil;
if n = nil then nargs := 1 else nargs := n↑.numdims;
end;
callop: begin
func := true;
nargs := 0;
with opn↑.arg1↑.vari↑ do (* see if procedure is defined *)
if tbits = 2 then n := p else n := nil;
if n <> nil then
begin
paramlist := n↑.paramlist;
if paramlist = nil then closep := false;
end;
end;
others: begin end; (* nothing to do *)
end;
if not absp then
begin
getToken; (* looking for opening '(' or '[' *)
if aref then dch := '[' else dch := '(';
with curToken do
if (ttype <> delimtype) or (ch <> dch) then (* not there - complain *)
begin
backup := true;
b := false; (* don't bother looking for args *)
if opn↑.op = timeop then
begin
opn↑.arg1 := defNode(svaltype); (* use zero *)
i := 1;
end
else if closep and not qp then (* query doesn't need to take any args *)
begin
pp10L('Need a ',7);
if aref then pp10('subscript ',10) else pp10('parameter ',10);
pp10('list here.',10);
errprnt;
end;
closep := false; (* so we know not to expect a closing ')' or ']' *)
end
else closep := true; (* make sure we look for matching ')' or ']' *)
end;
while b do
begin (* get the next argument *)
if paramlist = nil then arg := exprParse (* implies (not func) *)
else if paramlist↑.tbits <> 5 then arg := exprParse
else
with curToken do
begin (* looking for array passed by reference *)
getToken;
bp := ttype = identtype;
if bp then
begin (* is it a defined variable and an array? *)
v := varLookup(id);
if v <> nil then bp := (v↑.vtype <> pconstype) and odd(v↑.tbits)
else bp := false;
end;
if bp then
begin
arg := newNode;
arg↑.ntype := leafnode;
arg↑.ltype := varitype;
arg↑.vari := v;
arg↑.vid := v↑.name;
end
else (* no good *)
begin
pp20L(' Need an array varia',20); pp10('ble here ',8); errprnt;
arg := nil;
end;
end;
if arg <> nil then (* got one *)
begin
i := i + 1;
if func or aref or qp then (* add to arg list *)
begin
np := newNode;
np↑.ntype := listnode;
if func and (paramlist <> nil) then
with paramlist↑ do
begin (* check parameter for correct data type *)
np↑.lval := checkArg(arg,vtype);
if dtype <> nil then d := dtype↑.dim (* use dimension if it exists *)
else (* otherwise use default *)
if (vtype = transtype) or (vtype = frametype) then
d := distancedim↑.dim
else if vtype = rottype then d := angledim↑.dim
else d := nodim↑.dim;
dimCheck(arg,d);
d := nil;
paramlist := next;
if paramlist = nil then nargs := i;
end
else if aref then
begin
np↑.lval := checkArg(arg,svaltype);
dimCheck(arg,nodim↑.dim);
end
else np↑.lval := arg;
if nhdr = nil then nhdr := np else n↑.next := np;
n := np;
n↑.next := nil;
end
else
begin
with opn↑ do
case i of
1: arg1 := arg;
2: arg2 := arg;
3: arg3 := arg;
end;
end;
getToken; (* looking for separating ',' *)
with curToken do
if (ttype <> delimtype) or (ch <> ',') then b := false (* that's it *)
end
else b := false;
end;
if absp then (* looking for closing '|' *)
begin
with curToken do
if (ttype <> reswdtype) or (rtype <> optype) or (op <> absop) then
begin (* not there - complain *)
backup := true;
pp10(' Need a " ',9); ppChar(chr(vbar)); pp10('" here. ',7); errprnt;
end;
if opn↑.arg1 = nil then opn↑.arg1 := defNode(svaltype);
dat := getdtype(opn↑.arg1); (* now figure out what sort of || we've got *)
if dat = svaltype then opn↑.op := sabsop
else if dat = vectype then opn↑.op := vmagnop
else opn↑.op := tmagnop;
end
else if closep then
begin
if aref then dch := ']' else dch := ')';
backup := true; (* looking for closing ')' or ']' *)
getDelim(dch);
end
else backup := true;
if func or aref then (* store arg list in arg 2 *)
begin
while (i < nargs) or (paramlist <> nil) do
begin (* make sure we return the right size arg list *)
i := i + 1;
np := newNode;
np↑.ntype := listnode;
if func and (paramlist <> nil) then
begin
np↑.lval := defNode(paramlist↑.vtype);
paramlist := paramlist↑.next;
if paramlist = nil then nargs := i;
end
else np↑.lval := defNode(svaltype);
if nhdr = nil then nhdr := np else n↑.next := np;
n := np;
n↑.next := nil;
end;
opn↑.arg2 := nhdr;
end
else if qp then opn↑.arg2 := nhdr (* store arg list in arg 2 *)
else
with opn↑ do
case op of (* check args are of proper type & dimension *)
sqrtop: check1(svaltype);
logop,
expop,
asinop,
acosop,
adcop: begin
check1(svaltype);
dimCheck(arg1,nodim↑.dim);
end;
timeop: begin
check1(svaltype);
dimCheck(arg1,timedim↑.dim);
end;
sinop,
cosop,
tanop: begin
check1(svaltype);
dimCheck(arg1,angledim↑.dim);
end;
dacop,
atan2op: begin
check2(svaltype,svaltype);
dimCheck(arg1,nodim↑.dim);
dimCheck(arg2,nodim↑.dim);
end;
vmakeop: begin
check3(svaltype,svaltype,svaltype);
dimCheck(arg2,getdim(arg1,d));
dimCheck(arg3,d);
end;
unitvop: check1(vectype);
vsaxwrop: begin
check2(vectype,svaltype);
dimCheck(arg2,angledim↑.dim);
end;
tposop,
torientop,
tinvrtop: check1(transtype);
taxisop: check1(rottype);
fmakeop,
tmakeop: begin
check2(rottype,vectype);
dimCheck(arg1,angledim↑.dim);
if op = fmakeop then dimCheck(arg2,distancedim↑.dim);
end;
deproachop: begin
check1(frametype);
dimCheck(arg1,distancedim↑.dim);
end;
constrop: begin
check3(vectype,vectype,vectype);
dimCheck(arg1,distancedim↑.dim);
dimCheck(arg2,distancedim↑.dim);
dimCheck(arg3,distancedim↑.dim);
end;
end;
if aref then (* if array, check it's defined *)
if opn↑.arg1↑.vari↑.a = nil then nargs := i; (* it's not, assume all ok *)
if (not qp) and (i <> nargs) then
begin
pp10L(' Need ',6); ppInt(nargs); pp20(' arguments here. ',16); errprnt;
end;
if d <> nil then relNode(d); (* done with dimension node *)
end;
end;
(* function to parse expressions: exprParse *)
function exprParse; (* : nodep *)
var expstack, opstack: nodep; precstack: array [0..10] of integer;
opsp,i,j: integer; n,np: nodep; vp: varidefp; b,opseen,done,badp: boolean;
st: statementp;
function badexpr: nodep;
var n: nodep;
begin
n := newNode;
badexpr := n;
with n↑ do
begin ntype:= exprnode; op:= badop; arg1:= nil; arg2:= newNode; arg3:= nil end;
n := n↑.arg2;
with n↑ do begin ntype := leafnode; ltype := transtype; t := niltrans end;
if not badp then
begin
pp20L(' Bad expression ',15); errprnt;
badp := true;
end;
end;
function gettype(n: nodep): datatypes;
var d: datatypes;
begin
d := getdtype(n);
if (d = rottype) or (d = frametype) then d := transtype;
gettype := d;
end;
function getList(b: boolean): nodep;
var n: nodep;
begin (* array reference or procedure call *)
n := newNode;
with n↑ do
begin
ntype := exprnode;
if b then op := arefop else op := callop;
arg1 := newNode;
end;
with n↑.arg1↑ do
begin
ntype := leafnode;
ltype := varitype;
vari := vp;
vid := vp↑.name;
end;
getArgs(n); (* get subscripts/parameters *)
getList := n;
end;
procedure pushexp(n: nodep);
begin
n↑.next := expstack;
expstack := n;
end;
procedure cpushexp(n: nodep);
begin
if opseen then pushexp(n) (* all okay *)
else
begin (* yow! - we just saw an operand - complain *)
pp20L(' Bad expression - co',20); pp20('nsecutive operands ',18); errprnt;
badp := true;
end;
opseen := false; (* expecting an operator *)
end;
function popexp: nodep;
var n: nodep;
begin
if expstack <> nil then
begin
n := expstack;
expstack := expstack↑.next;
n↑.next := nil;
popexp := n;
end
else
begin (* this probably can't happen, but... *)
pp20L(' Gack! - parse opera',20); pp20('nd expression stack ',20);
pp10('underflow ',9); errprnt;
badp := true;
popexp := badexpr;
end;
end;
procedure pushop;
begin
if opsp <= 9 then
begin
n↑.next := opstack;
opstack := n;
opsp := opsp + 1;
precstack[opsp] := i;
end
else
begin
pp20L(' Gack! - parse opera',20); pp20('tor expression stack',20);
pp10(' overflow ',9); errprnt;
badp := true;
end;
opseen := true; (* expecting an operand *)
end;
procedure popop;
var n,n1,d: nodep; d1,d2: datatypes;
begin (* popop *)
d := nil;
n := opstack;
opstack := n↑.next;
opsp := opsp - 1;
with n↑ do
begin (* get its operand(s) *)
next := nil;
arg3 := nil;
if (op = negop) or (op = notop) then arg2 := nil
else
begin
arg2 := popexp;
if expstack = nil then
begin (* whoops - wasn't any arg 2 *)
expstack := arg2;
arg2 := badexpr;
end;
end;
arg1 := popexp;
if op <= modop then
begin
arg1 := checkArg(arg1,svaltype); (* check datatypes of args *)
if op <> notop then arg2 := checkArg(arg2,svaltype);
if (op <= sneop) or (op >= maxop) then (* relation, max, min & mod *)
begin
if (op <> intop) and (op <> idivop) then (* don't care about these *)
dimCheck(arg2,getdim(arg1,d)); (* does arg2 match dimension of arg1 *)
end
else if op <= sexpop then (* check dimensions too *)
begin (* args better be dimensionless *)
dimCheck(arg1,nodim↑.dim);
if op <> notop then dimCheck(arg2,nodim↑.dim);
end
end
else if op = vdotop then
begin
arg1 := checkArg(arg1,vectype);
arg2 := checkArg(arg2,vectype);
end
else if op = wrtop then
begin
arg1 := checkArg(arg1,vectype);
arg2 := checkArg(arg2,transtype);
end
else if op = ftofop then
begin
arg1 := checkArg(arg1,transtype);
arg2 := checkArg(arg2,transtype);
dimCheck(arg2,getdim(arg1,d)); (* does arg2 match dimension of arg1 *)
end
else if op >= addop then (* need to determine proper op for given args *)
case op of
negop: begin (* see if snegop or vnegop *)
d1 := getdtype(arg1);
if d1 = svaltype then op := snegop
else if d1 = vectype then op := vnegop
else begin n1 := badexpr; n1↑.arg1 := n; n := n1 end;
end;
addop: begin
dimCheck(arg2,getdim(arg1,d)); (* does arg2 match dimension of arg1 *)
d1 := gettype(arg1);
d2 := gettype(arg2);
if d1 = undeftype then begin d1 := d2; arg1↑.vari↑.vtype := d1 end;
if d2 = undeftype then
begin
if d1 = transtype then d2 := vectype else d2 := d1;
arg2↑.vari↑.vtype := d2
end;
if (d1 = svaltype) and (d2 = svaltype) then op := saddop
else if (d1 = vectype) and (d2 = vectype) then op := vaddop
else if (d1 = transtype) and (d2 = vectype) then op := tvaddop
else begin op := saddop; n1 := badexpr; n1↑.arg1 := n; n := n1 end;
end;
subop: begin
dimCheck(arg2,getdim(arg1,d)); (* does arg2 match dimension of arg1 *)
d1 := gettype(arg1);
d2 := gettype(arg2);
if d1 = undeftype then begin d1 := d2; arg1↑.vari↑.vtype := d1 end;
if d2 = undeftype then
begin
if d1 = transtype then d2 := vectype else d2 := d1;
arg2↑.vari↑.vtype := d2
end;
if (d1 = svaltype) and (d2 = svaltype) then op := ssubop
else if (d1 = vectype) and (d2 = vectype) then op := vsubop
else if (d1 = transtype) and (d2 = vectype) then op := tvsubop
else begin op := ssubop; n1 := badexpr; n1↑.arg1 := n; n := n1 end;
end;
mulop: begin
d1 := gettype(arg1);
d2 := gettype(arg2);
if d1 = undeftype then begin d1 := d2; arg1↑.vari↑.vtype := d1 end;
if d2 = undeftype then begin d2 := d1; arg2↑.vari↑.vtype := d2 end;
if (d1 = svaltype) and (d2 = svaltype) then op := smulop
else if (d1 = svaltype) and (d2 = vectype) then op := svmulop
else if (d1 = vectype) and (d2 = svaltype) then op := vsmulop
else if (d1 = vectype) and (d2 = vectype) then op := crossvop
else if (d1 = transtype) and (d2 = vectype) then op := tvmulop
else if (d1 = transtype) and (d2 = transtype) then op := ttmulop
else begin op := smulop; n1 := badexpr; n1↑.arg1 := n; n := n1 end;
if (op = ttmulop) or (op = tvmulop) then
dimCheck(arg2,getdim(arg1,d)); (* does arg2 match dimension of arg1 *)
end;
divop: begin
d1 := gettype(arg1);
d2 := gettype(arg2);
if d1 = undeftype then
begin d1 := svaltype; arg1↑.vari↑.vtype := d1 end;
if d2 = undeftype then
begin d2 := svaltype; arg2↑.vari↑.vtype := d2 end;
if (d1 = svaltype) and (d2 = svaltype) then op := sdivop
else if (d1 = vectype) and (d2 = svaltype) then op := vsdivop
else begin op := sdivop; n1 := badexpr; n1↑.arg1 := n; n := n1 end;
end;
end;
pushexp(n); (* save it as operand for next operator *)
if d <> nil then relNode(d);
end;
end (* popop *);
function opprecedence(op: exprtypes): integer;
var i: integer;
begin
case op of
eqvop: i := 1;
orop,
xorop: i := 2;
andop: i := 3;
sltop,
sleop,
seqop,
sgeop,
sgtop,
sneop: i := 4;
addop,
subop: i := 5;
wrtop: i := 6;
mulop,
divop,
maxop,
minop,
idivop,
modop,
vdotop: i := 7;
sexpop,
ftofop: i := 8;
negop,
notop: i := 9;
others: i := 0;
end;
opprecedence := i;
end;
begin (* exprParse *)
expstack := nil;
opstack := nil;
opsp := 0;
precstack[0] := -1;
done := false;
opseen := true; (* expecting an operand *)
badp := false; (* haven't complained about expression yet *)
repeat
getToken;
with curToken do
begin
case ttype of (* see what we've got *)
labeldeftype:
begin done := true; backup := true end;
delimtype:
if ch = '(' then
begin
cpushexp(exprParse); (* get the parenthesized expression *)
getDelim(')'); (* get the closing ')' *)
end
else begin done := true; backup := true end;
reswdtype:
if rtype <> optype then begin done := true; backup := true end
else if not opseen and (op = absop) then
begin done := true; backup := true end
else if not (opseen and (op = addop)) then (* we want to ignore unary + *)
begin
if opseen and (op = subop) then op := negop;
n := newNode;
n↑.ntype := exprnode;
n↑.op := op;
i := opprecedence(op);
if i = 0 then (* really an operand *)
begin
getArgs(n); (* get any arguments op needs *)
cpushexp(n); (* save operand for its operator *)
end
else if opseen and ((op <> negop) and (op <> notop)) then
begin (* yow! - we just saw an operator - complain *)
pp20L(' Bad expression - co',20); pp20('nsecutive operators ',19);
errprnt;
badp := true;
end
else if i > precstack[opsp] then (* higher precedence so push on stack *)
pushop
else (* lower precedence *)
begin
while (i <= precstack[opsp]) and (i < 9) do popop; (* 9 = prec(not,neg) *)
pushop;
end;
end;
constype: cpushexp(cons);
identtype:
begin
vp := varLookup(id);
if vp = nil then
begin (* undefined variable *)
vp := makeUVar(undeftype,id); (* define it somewhat *)
getToken; (* see if it's supposed to be a procedure or array *)
backup := true; (* we're just peeking *)
pp10L(' Undeclare',10);
if (ttype = delimtype) and ((ch = '(') or (ch = '[')) then
if ch = '[' then
begin
vp↑.tbits := 1; (* array *)
vp↑.a := nil;
pp20('d array variable ',16);
end
else
begin
vp↑.tbits := 2; (* procedure *)
vp↑.p := nil;
pp20('d procedure ',11);
if newDeclarations <> nil then
if newDeclarations↑.variables = vp then
begin
newDeclarations↑.nlines := 3;
st := newDeclarations; (* find block they're in *)
while st↑.stype <> blocktype do st := st↑.last;
vp↑.p := newNode;
with vp↑.p↑ do
begin
ntype := procdefnode;
ptype := undeftype;
level := st↑.level + 1;
pname := vp;
paramlist := nil;
body := newStatement;
appendEnd(body,body);
with body↑ do
begin stype := blocktype; bparent := curBlock; blkid := nil;
nlines := 2; numvars := 0; level := st↑.level + 2;
bcode := next; variables := nil end;
body↑.next := newStatement; (* append a return *)
with body↑.next↑ do
begin
stype := returntype; retval := nil; exprs := nil;
last := vp↑.p↑.body; rproc := vp↑.p;
end;
end;
end
end
else pp10('d variable',10);
pp20(' - will try to defin',20); pp5('e it.',5); errprnt;
badp := true;
end;
if vp↑.vtype = pconstype then (* constant *)
begin
np := newNode; (* need to make a pointer to it *)
with np↑ do
begin
ntype := leafnode;
ltype := pconstype;
cname := vp;
pcval := vp↑.c;
end;
cpushexp(np);
end
else if odd(vp↑.tbits) or (vp↑.tbits = 2) then
begin (* array reference or procedure call *)
n := getList(odd(vp↑.tbits));
cpushexp(n);
end
else (* variable *)
begin
getToken; (* see if there's a subscript or parameter list *)
backup := true; (* we're just peeking *)
b := (ttype = delimtype) and ((ch = '(') or (ch = '['));
if b then
begin
if (vp↑.level = 0) and (vp↑.offset in [0,2,4,6,8,12]) then
begin (* device offsets: arms: 0,4 hands: 2,6 driver/vise: 8,12 *)
n := getList(true);
n↑.op := jointop; (* joint reference *)
end
else
begin
pp20L('Not an array or proc',20); pp10('edure! ',7); errprnt;
badp := true;
n := newNode;
with n↑ do
begin
ntype := exprnode;
op := badop;
arg1 := getList(ch = '[');
arg2 := defNode(vp↑.vtype);
arg3 := nil;
end;
end
end
else
begin
n := newNode;
with n↑ do
begin
ntype := leafnode;
ltype := varitype;
vari := vp;
vid := vp↑.name;
end;
end;
cpushexp(n);
end;
end;
end;
end;
until done;
while opsp > 0 do popop; (* bind the rest of the operators *)
if expstack <> nil then exprParse := popexp (* return what's left on stack *)
else exprParse := nil;
while expstack <> nil do relNode(popexp); (* probably don't need, but... *)
end;
(* auxiliary expression mungers: relExpr & evalOrder *)
procedure relExpr (* n: nodep *);
var b: boolean; st,stp: strngp;
begin
b := true;
if n = nil then b := false
else
with n↑ do
case ntype of
exprnode: begin
relExpr(arg1);
relExpr(arg2);
relExpr(arg3);
end;
leafnode: case ltype of
vectype: if v↑.refcnt <= 1 then relVector(v)
else v↑.refcnt := v↑.refcnt - 1;
transtype: if t↑.refcnt <= 1 then relTrans(t)
else t↑.refcnt := t↑.refcnt - 1;
strngtype: if (length <> 2) or (str↑.ch[1] <> chr(CR)) or
(str↑.ch[2] <> chr(LF)) then
begin
st := str;
while st <> nil do
begin stp := st↑.next; relStrng(st); st := stp end;
end
else b := false;
others: begin end; (* nothing to do *)
end;
listnode: begin
relExpr(lval);
relExpr(next);
end;
ffnode: begin
if pdef and ((ff↑.ntype <> exprnode) or (ff↑.op <> vmkfrcop)) then
relNode(ff)
else relExpr(ff);
end;
forcenode:begin
relExpr(fval);
relExpr(fvec);
relExpr(fframe);
end;
arraydefnode: relExpr(bounds);
bnddefnode:begin
relExpr(lower);
relExpr(upper);
relExpr(next);
end;
end;
if b then relNode(n);
end;
function evalOrder(what,last: nodep; pcons: boolean): nodep;
var vp: varidefp; n,nv: nodep; tbits: integer;
begin
if what <> nil then
with what↑ do
case ntype of
exprnode:
if (op < ioop) or (op = adcop) or (op = dacop) then
begin (* regular ops are easy to handle *)
next := last;
last := evalOrder(arg1,what,false); (* all ops have at least one arg *)
if arg2 <> nil then last := evalOrder(arg2,last,false);
if arg3 <> nil then last := evalOrder(arg3,last,false);
end
else if (op = grinchop) then last := evalOrder(arg1,last,true)
else if op < specop then (* query or inscalar *)
begin
what↑.next := last;
if op = inscalarop then last := what (* inscalar has no args *)
else if arg2 = nil then last := what (* query has no print list *)
else last := evalOrder(arg2,what,false); (* handle query's print list *)
end
else if op = arefop then
begin
arg1↑.next := last;
last := evalOrder(arg2,arg1,true); (* need to push constants too *)
end
else if op = jointop then
begin
next := last;
last := evalOrder(arg2↑.lval,what,false); (* ** only one subscript for now ** *)
end
else if op = callop then
begin
what↑.next := last;
last := what;
if arg2 <> nil then
begin
with arg1↑.vari↑ do
if p <> nil then vp := p↑.paramlist else vp := nil;
n := arg2;
while n <> nil do
begin (* evaluate parameters *)
if vp <> nil then
begin
tbits := vp↑.tbits;
vp := vp↑.next;
end
else tbits := 0;
with n↑.lval↑ do
begin
if (tbits = 4) then (* call by reference *)
if ((ntype = exprnode) and (op <> arefop)) or (* expression *)
((ntype = leafnode) and (ltype <> varitype)) (* constant *)
then tbits := 0; (* change to call by value *)
if tbits = 0 then last := evalOrder(n↑.lval,last,false)
else if (tbits = 4) and (ntype = exprnode) then
last := evalOrder(arg2,last,true); (* push subscripts *)
end;
n := n↑.next;
end
end
end
else if op = badop then (* stick default value node so it goes on stack *)
begin
arg2↑.next := last;
last := arg2;
end;
listnode:
begin
last := evalOrder(lval,last,pcons); (* set up this list element's value *)
if next <> nil then
last := evalOrder(next,last,pcons); (* now move down the list *)
end;
bnddefnode:
begin
last := evalOrder(lower,last,false); (* set up this subscript's values *)
last := evalOrder(upper,last,false);
if next <> nil then
last := evalOrder(next,last,false); (* now move down the list *)
end;
leafnode:
if pcons or (ltype = varitype) then
begin (* get variable's value or if asked push constants *)
next := last;
last := what;
end;
durnode:
last := evalOrder(durval,last,false); (* evaluate duration value *)
deprnode,
apprnode,
destnode:
begin
last := evalOrder(loc,last,false); (* evaluate location *)
if code <> nil then
if code↑.stype = signaltype then
if code↑.event↑.ntype <> leafnode then
last := evalOrder(code↑.event↑.arg2,last,true);
end;
viaptnode,
byptnode:
begin
last := evalOrder(via,last,false); (* evaluate location *)
nv := vclauses;
while nv <> nil do (* check for any specified duration *)
if nv↑.ntype = durnode then
begin
last := evalOrder(nv,last,false); (* evaluate duration *)
nv := nil;
end
else nv := nv↑.next;
nv := vclauses;
while nv <> nil do (* now check for any specified velocity *)
if nv↑.ntype = velocitynode then
begin
last := evalOrder(nv↑.clval,last,false); (* evaluate velocity vector *)
nv := nil;
end
else nv := nv↑.next;
if vcode <> nil then
if vcode↑.stype = signaltype then
if vcode↑.event↑.ntype <> leafnode then
last := evalOrder(vcode↑.event↑.arg2,last,true);
end;
forcenode:
begin
last := evalOrder(fval,last,false); (* evaluate force value *)
end;
end;
evalOrder := last;
end;
(* aux routine to set up evaluation order for motions: moveOrder *)
procedure moveOrder(st: statementp);
var b,byp,movep,operatep,centerp,openp,floatp,arrp,gathering,notaxis,ffp: boolean;
cl, lexpr, dest, bydest, appr, depr, wobble, sfac, dur, vel, torquecl: nodep;
load, stiff, ffr, fn1: nodep; useForce, cmForce: integer;
procedure ffcompare(ff2: nodep);
var b: boolean; v1,v2: varidefp;
begin (* ffcompare *)
if ff2 <> nil then
if ffr = nil then ffr := ff2 (* remember first force frame we see *)
else
begin (* see if they match *)
b := ffr↑.csys = ff2↑.csys; (* make sure they use same coord sys *)
v1 := nil;
v2 := nil;
with ffr↑.ff↑ do
if ntype = leafnode then
if ltype = pconstype then v1 := cname
else if ltype = varitype then v1 := vari else b := false
else if (ntype = exprnode) and (op = arefop) then v1 := arg1↑.vari
else b := false;
with ff2↑.ff↑ do
if ntype = leafnode then
if ltype = pconstype then v2 := cname
else if ltype = varitype then v2 := vari else b := false
else if (ntype = exprnode) and (op = arefop) then v2 := arg1↑.vari
else b := false;
if not (b or (v1 = v2)) then
begin
pp20L(' MOVE statement has ',20); pp20('multiply defined for',20);
pp10('ce frames ',9); errprnt;
end;
end;
end (* ffcompare *);
procedure fcheck(fn: nodep); (* check force axis is ok *)
var vec: vectorp;
procedure badvector(fn: nodep); (* axis error *)
var bad: nodep;
begin
pp20L(' Force direction mus',20); pp20('t be along an axis -',20);
pp20(' assuming zhat ',14); errprnt;
bad := newNode;
with bad↑ do
begin
ntype := exprnode;
op := badop;
arg1 := fn↑.fvec;
arg2 := newNode;
end;
with bad↑.arg2↑ do
begin ntype := leafnode; ltype := vectype; v := zhat end;
fn↑.fvec := bad;
end;
begin (* fcheck *) (* note: can't really check variables or expressions *)
ffcompare(fn↑.fframe); (* first check its force frame *)
if (useForce + cmForce > 1) and notaxis then
begin (* first force spec was bad - fix it now *)
pp20L(' In previous force s',20); pp20('pecification: ',13);
badvector(fn1);
end;
vec := nil;
with fn↑.fvec↑ do
if ntype = leafnode then vec := pcval↑.v (* first check if axis vector *)
else if op = vnegop then (* or negative axis vector *)
if arg1↑.ntype = leafnode then vec := arg1↑.pcval↑.v;
if not((vec = xhat) or (vec = yhat) or (vec = zhat)) then
if useForce + cmForce = 1 then
begin (* single sense/apply *)
fn1 := fn;
notaxis := true; (* remember that it's not along an axis *)
end
else badvector(fn); (* multiple axes - error *)
end (* fcheck *);
begin (* moveOrder *)
arrp := false;
byp := false;
dest := nil;
bydest := nil;
appr := nil;
depr := nil;
wobble := nil;
sfac := nil;
dur := nil;
load := nil;
useForce := 0;
cmForce := 0;
stiff := nil;
gathering := false;
ffp := false;
ffr := nil;
fn1 := nil;
notaxis := false;
movep := false;
operatep := false;
centerp := false;
floatp := false;
openp := false;
with st↑ do
if (stype = movetype) or (stype = jtmovetype) then movep := true
else if stype = operatetype then operatep := true
else if stype = centertype then centerp := true
else if stype = floattype then floatp := true else openp := true;
cl := st↑.clauses;
if cl <> nil then
with cl↑ do
if (ntype = ffnode) and pdef then
begin (* flush any system created fframes *)
st↑.clauses := cl↑.next; (* though we may recreate it below *)
relExpr(cl);
cl := st↑.clauses;
end;
while cl <> nil do (* run through the clauses *)
with cl↑ do
begin
case ntype of
destnode: begin
if dest <> nil then
begin
pp20L(' Can only specify on',20); pp20('e destination for a ',20);
pp10('motion! ',7); errprnt;
end;
dest := cl;
end;
apprnode: if loc <> nil then begin appr := cl; byp := false end;
deprnode: if loc <> nil then depr := cl;
viaptnode: byp := false;
byptnode: begin byp := true; bydest := cl end;
gathernode: gathering := true;
stiffnode: begin stiff := cl; ffcompare(cocff) end;
wobblenode: wobble := cl;
sfacnode: sfac := cl;
durnode: dur := cl;
loadnode: load := cl;
ffnode: begin
ffcompare(cl);
if not ffp then begin ffr := cl; ffp := true end;
end;
forcenode: begin
useForce := useForce + 1;
if movep then fcheck(cl);
end;
cmonnode: with cl↑.cmon↑.oncond↑ do
if ntype = forcenode then
begin
cmForce := cmForce + 1;
if movep then fcheck(cl↑.cmon↑.oncond);
end
else if ntype = arrivalnode then
begin
if arrp then
begin
pp20L(' Can only specify on',20); pp20('e "ON ARRIVAL DO" fo',20);
pp20('r a motion! ',11); errprnt;
end;
arrp := true;
end;
end;
cl := next;
end;
if (dest = nil) and (not byp) and (appr = nil) then
begin
if movep and (st↑.clauses <> nil) then
begin
pp20L(' Need destination fo',20); pp20('r motion statement! ',19); errprnt;
end
end;
if notaxis and (useForce + cmForce = 1) then
begin (* single sense/apply *)
b := ffr = nil;
if not b then
if not ffr↑.pdef then
begin
pp20L(' Can''t specify a for',20); pp20('ce frame with a rand',20);
pp20('om force vector ',15); errprnt;
b := true;
end;
if b then
begin
ffr := newNode; (* make up a new force frame *)
with ffr↑ do
begin
next := st↑.clauses;
ntype := ffnode;
ff := newNode;
with ff↑ do
begin
ntype := exprnode;
op := vmkfrcop; (* need to compute force frame *)
arg1 := copyExpr(fn1↑.fvec,true);
arg2 := nil;
arg3 := nil;
end;
csys := true; (* use world coords *)
pdef := true;
end;
st↑.clauses := ffr;
end;
end
else if (ffr <> nil) and not ffp then
begin (* need to add force frame specification *)
cl := ffr; (* force frame from force or stiffness node *)
ffr := newNode; (* make up a new force frame *)
with ffr↑ do
begin
next := st↑.clauses;
ntype := ffnode;
ff := copyExpr(cl↑.ff,true);
csys := true; (* use world coords *)
pdef := true;
end;
st↑.clauses := ffr;
end;
(* now set up those expressions that need to be evaluated for this motion *)
lexpr := nil;
with st↑ do
if cf <> nil then (* evaluate control frame *)
if cf↑.ntype <> leafnode then
if cf↑.op = arefop then
lexpr := evalOrder(cf↑.arg2,nil,true) (* push array subscripts *)
else lexpr := evalOrder(cf↑.arg2↑.lval,nil,true); (* only 1 sub for jointop *)
if not floatp then
begin
if (sfac <> nil) and ((dest <> nil) or (bydest <> nil)) then (* evaluate speed factor *)
lexpr := evalOrder(sfac↑.clval,lexpr,false);
if dur <> nil then (* evaluate global time duration *)
lexpr := evalOrder(dur↑.durval,lexpr,false);
end;
if movep then
if wobble <> nil then (* evaluate wobble *)
lexpr := evalOrder(wobble↑.clval,lexpr,false);
if (movep or floatp) and (load <> nil) then (* evaluate load *)
begin
lexpr := evalOrder(load↑.loadval,lexpr,false);
lexpr := evalOrder(load↑.loadvec,lexpr,false);
end;
if movep then
begin (* MOVE statement has extra clauses *)
if ffr <> nil then (* evaluate force frame *)
lexpr := evalOrder(ffr↑.ff,lexpr,false);
if stiff <> nil then (* deal with stiffness *)
begin
lexpr := evalOrder(stiff↑.fv,lexpr,false); (* evaluate force vector *)
lexpr := evalOrder(stiff↑.mv,lexpr,false); (* evaluate torque vector *)
end;
cl := st↑.clauses;
while cl <> nil do (* run through clauses *)
begin
if cl↑.ntype = forcenode then (* evaluate bias force values *)
lexpr := evalOrder(cl↑.fval,lexpr,false);
cl := cl↑.next;
end;
if depr <> nil then (* evaluate departure *)
lexpr := evalOrder(depr,lexpr,false);
cl := st↑.clauses;
while cl <> nil do (* run through clauses *)
begin
if (cl↑.ntype = viaptnode) or (cl↑.ntype = byptnode) then
lexpr := evalOrder(cl,lexpr,false); (* evaluate via & by points *)
cl := cl↑.next;
end;
if appr <> nil then (* evaluate approach *)
lexpr := evalOrder(appr,lexpr,false);
end
else if operatep then
begin (* handle OPERATE *)
torquecl := nil;
vel := nil;
cl := st↑.clauses;
while cl <> nil do (* run through clauses *)
with cl↑ do
begin
if ntype = forcenode then
if ftype = torque then torquecl := cl
else if ftype = angvelocity then vel := cl;
cl := next;
end;
if vel <> nil then (* evaluate angular velocity *)
lexpr := evalOrder(vel↑.fval,lexpr,false);
if torquecl <> nil then (* evaluate torque *)
lexpr := evalOrder(torquecl↑.fval,lexpr,false);
end
else if openp then
begin (* handle OPEN/CLOSE *)
cl := st↑.clauses;
while cl <> nil do (* run through clauses *)
begin
if cl↑.ntype = swtnode then (* evaluate stop wait time for vise *)
begin
lexpr := evalOrder(cl↑.clval,lexpr,false);
cl := nil;
end
else cl := cl↑.next;
end;
if (dest = nil) and (bydest <> nil) then (* evaluate BY = dest *)
lexpr := evalOrder(bydest,lexpr,false);
end;
if (not (centerp or floatp)) and (dest <> nil) then (* evaluate destination *)
lexpr := evalOrder(dest,lexpr,false);
if not floatp then
begin
cl := st↑.clauses;
while cl <> nil do (* run through clauses *)
with cl↑ do
begin
if (ntype = cmonnode) and errHandlerp then (* evaluate error conds *)
lexpr := evalOrder(cmon↑.oncond↑.eexpr,lexpr,false);
cl := next;
end;
end;
st↑.exprs := lexpr;
end (* moveOrder *);
(* assignParse *)
procedure assignParse(st: statementp; np: nodep);
var n,dp: nodep; d1,d2: datatypes; b: boolean;
begin
with st↑ do
begin
exprs := nil;
aval := nil;
bad := false; (* assume statement is ok *)
if np <> nil then what := np (* use previously parsed node *)
else what := exprParse; (* see what we're assigning to *)
if what <> nil then
with what↑ do
begin
b := false;
n := nil;
if (ntype = leafnode) and (ltype = varitype) then n := what
else b := not ((ntype = exprnode) and
((op = callop) or (op = arefop) or (op = dacop)) );
if b and (ntype = exprnode) and
((op = tposop) or (op = torientop) or (op = deproachop)) then
if (arg1↑.ntype = leafnode) and (arg1↑.ltype = varitype) then
begin b := false; n := arg1 end
else b := not ((arg1↑.ntype = exprnode) and (arg1↑.op = arefop));
if n <> nil then (* make sure it's not a device *)
if n↑.vari↑.level = 0 then
b := n↑.vari↑.offset in [0,2,4,6,8,12];
(* offsets: arms: 0,4 hands: 2,6 driver/vise: 8,12 *)
if b then
begin (* no good *)
if n = nil then
begin
pp20L(' Can only assign to ',20); pp10('a variable',10);
end
else
begin
pp20L(' Can''t assign values',20); pp20(' to devices ',11);
end;
errprnt;
bad := true; (* mark statement as bad *)
end
else if (ntype = exprnode) and ((op = callop) or (op = dacop)) then
begin
if op = callop then stype := calltype;
exprs := evalOrder(what,nil,true);
end
else if (ntype = leafnode) and (ltype = varitype) then
begin
if vari↑.vtype = undeftype then
begin
getToken;
backup := true;
with curToken do
if (ttype = delimtype) and (ch = ';') then
begin
vari↑.tbits := 2; (* make it a procedure *)
vari↑.p := nil;
n := newNode;
with n↑ do
begin
ntype := exprnode;
op := callop;
arg1 := what;
arg2 := nil;
arg3 := nil;
next := nil;
end;
what := n;
stype := calltype;
exprs := nil;
end
end
end;
end;
if stype = assigntype then
begin
getToken; (* look for the ":=" *)
with curToken do
if (ttype <> reswdtype) or (rtype <> stmnttype) or
(stmnt <> assigntype) then
begin
backup := true;
pp20L(' Expecting ":=" here',20); errprnt;
end;
aval := exprParse;
if (what <> nil) and (aval <> nil) then
begin
d1 := getDtype(what);
d2 := getDtype(aval);
if d1 = undeftype then
begin
if (d2 = transtype) and (aval↑.ntype = exprnode) then
with aval↑ do (* check if it shouldn't really be a frame *)
if (op = constrop) or (op = fmakeop) then d2 := frametype
else if (ttmulop <= op) and (op <= tvsubop) then d2 := getDtype(arg1);
d1 := d2;
if what↑.ntype = leafnode then what↑.vari↑.vtype := d1
else what↑.arg1↑.vari↑.vtype := d1;
end;
if d2 = undeftype then
begin
d2 := d1;
if aval↑.ntype = leafnode then aval↑.vari↑.vtype := d2
else aval↑.arg1↑.vari↑.vtype := d2;
end;
if (d1 = frametype) or (d1 = rottype) then d1 := transtype;
if (d2 = frametype) or (d2 = rottype) then d2 := transtype;
if d1 <> d2 then
begin (* no good *)
b := true;
pp20L(' Can''t assign a ',16); ppDtype(d2);
pp10(' to a ',6); ppDtype(d1); errprnt;
n := newNode;
with n↑ do
begin
ntype := exprnode;
op := badop;
arg1 := aval;
arg2 := defNode(d1);
arg3 := nil;
end;
aval := n;
end
else
begin
dp := nil;
dimCheck(aval,getDim(what,dp));
relNode(dp);
with what↑ do
if ntype = leafnode then n := nil
else if op = arefop then n := arg2
else if arg1↑.ntype = leafnode then n := nil
else n := arg1↑.arg2;
if n <> nil then
n := evalorder(n,nil,true); (* deal with subscripts *)
exprs := evalorder(aval,n,true);
end;
end
else if aval <> nil then
begin
backup := true;
bad := true; (* mark statement as bad *)
pp20L(' Expecting an expres',20); pp10('sion here ',9); errprnt;
end
end;
end;
end;
(* forParse *)
procedure forParse(st: statementp);
var lexp,dim: nodep; b: boolean;
begin
with st↑ do
begin
b := false;
forvar := checkArg(exprParse,svaltype); (* get the for variable *)
initial := nil;
step := nil;
final := nil;
dim := nil;
with forvar↑ do (* make sure it's a variable *)
if not (((ntype = leafnode) and (ltype = varitype)) or
((ntype = exprnode) and (op = arefop))) then
begin (* no good *)
bad := true; (* mark statement as bad *)
pp20L(' Need a scalar varia',20); pp10('ble here. ',9); errprnt;
end
else
bad := false; (* statement is ok *)
dim := getdim(forvar,dim);
getToken; (* look for the ":=" *)
with curToken do
if (ttype <> reswdtype) or (rtype <> stmnttype) or (stmnt <> assigntype) then
begin
backup := true;
pp20L(' Expecting ":=" here',20); errprnt;
end;
initial := checkArg(exprParse,svaltype); (* get the initial value *)
dimCheck(initial,dim);
getToken; (* look for the "STEP" *)
with curToken do
if (ttype <> reswdtype) or (rtype <> filtype) or (filler <> steptype) then
begin
backup := true;
pp20L(' Expecting a "STEP" ',20); pp5('here.',5); errprnt;
end;
step := checkArg(exprParse,svaltype); (* get the step value *)
dimCheck(step,dim);
getToken; (* look for the "TO" *)
with curToken do
if (ttype <> reswdtype) or (rtype <> filtype) or (filler <> untltype) then
begin
backup := true;
pp20L(' Expecting an "UNTIL',20); pp10('" here. ',7); errprnt;
end;
final := checkArg(exprParse,svaltype); (* get the final value *)
dimCheck(final,dim);
with forvar↑ do
if ntype = leafnode then lexp := nil
else lexp := evalOrder(arg2,nil,true); (* push array subscripts *)
lexp := evalOrder(initial,lexp,true);
lexp := evalOrder(step,lexp,true);
exprs := evalOrder(final,lexp,true);
if dim <> nil then relNode(dim);
end;
end;
(* affixParse & unfixParse *)
procedure affixParse(st: statementp);
var opt,b: boolean; lexp: nodep;
begin
with st↑, curToken do
begin
bad := false; (* assume statement is ok *)
if fieldNum = 1 then
begin
frame1 := checkArg(exprParse,frametype);
with frame1↑ do (* make sure it's a variable *)
if not (((ntype = leafnode) and (ltype = varitype)) or
((ntype = exprnode) and (op = arefop))) then
begin (* no good *)
pp20L(' Need a frame variab',20); pp10('le here. ',8); errprnt;
bad := true; (* mark statement as bad *)
end;
getToken; (* look for the "TO" *)
if (ttype <> reswdtype) or (rtype <> filtype) or (filler <> totype) then
begin
backup := true;
pp20L(' Expecting "TO" here',20); errprnt;
end;
frame2 := checkArg(exprParse,frametype);
with frame2↑ do (* make sure it's a variable *)
if not (((ntype = leafnode) and (ltype = varitype)) or
((ntype = exprnode) and (op = arefop))) then
begin (* no good *)
pp20L(' Need a frame variab',20); pp10('le here. ',8); errprnt;
bad := true; (* mark statement as bad *)
end;
opt := true;
byvar := nil;
if nlines = 1 then atexp := nil; (* may not be editing this now *)
rigid := true; (* default flavor affixment *)
while opt do
begin (* now look for optional parts: AT, BY & how *)
getToken;
if (ttype = reswdtype) and (rtype = filtype) and (filler = bytype) then
begin
byvar := checkArg(exprParse,transtype); (* get the BY var *)
dimCheck(byvar,distancedim↑.dim);
with byvar↑ do (* make sure it's a variable *)
begin
b := ((ntype <> leafnode) or (ltype <> varitype));
if b then b := ((ntype <> exprnode) or (op <> arefop));
end;
if b then
begin (* no good *)
bad := true; (* mark statement as bad *)
pp20L(' Need a trans variab',20); pp10('le here. ',8); errprnt;
end
end
else if (ttype = reswdtype) and (rtype = filtype) and
(filler = attype) then
begin
atexp := checkArg(exprParse,transtype); (* get the AT expression *)
dimCheck(atexp,distancedim↑.dim);
end
else if (ttype = reswdtype) and (rtype = filtype) and
(filler = rigidlytype) then rigid := true
else if (ttype = reswdtype) and (rtype = filtype) and
(filler = nonrigidlytype) then rigid := false
else opt := false;
end;
end
else
begin
atexp := checkArg(exprParse,transtype); (* get the AT expression *)
dimCheck(atexp,distancedim↑.dim);
end;
with frame1↑ do
if ntype = leafnode then lexp := nil
else lexp := evalOrder(arg2,nil,true); (* push array subscripts *)
with frame2↑ do
if ntype <> leafnode then lexp := evalOrder(arg2,lexp,true);
if byvar <> nil then
with byvar↑ do
if ntype <> leafnode then lexp := evalOrder(arg2,lexp,true);
if atexp <> nil then exprs := evalOrder(atexp,lexp,true)
else exprs := lexp;
end;
end;
procedure unfixParse(st: statementp);
var lexp: nodep;
begin
with st↑ do
begin
bad := false; (* assume statement is ok *)
frame1 := checkArg(exprParse,frametype);
with frame1↑ do (* make sure it's a variable *)
if not (((ntype = leafnode) and (ltype = varitype)) or
((ntype = exprnode) and (op = arefop))) then
begin (* no good *)
pp20L(' Need a frame variab',20); pp10('le here. ',8); errprnt;
bad := true; (* mark statement as bad *)
end;
getToken; (* look for the "FROM" *)
with curToken do
if (ttype <> reswdtype) or (rtype <> filtype) or (filler <> fromtype) then
begin
backup := true;
pp20L(' Expecting a "FROM" ',20); pp5('here.',5); errprnt;
end;
frame2 := checkArg(exprParse,frametype);
with frame2↑ do (* make sure it's a variable *)
if not (((ntype = leafnode) and (ltype = varitype)) or
((ntype = exprnode) and (op = arefop))) then
begin (* no good *)
pp20L(' Need a frame variab',20); pp10('le here. ',8); errprnt;
bad := true; (* mark statement as bad *)
end;
with frame1↑ do
if ntype = leafnode then lexp := nil
else lexp := evalOrder(arg2,nil,true); (* push array subscripts *)
with frame2↑ do
if ntype <> leafnode then exprs := evalOrder(arg2,lexp,true)
else exprs := lexp;
byvar := nil;
atexp := nil;
end;
end;
(* enableParse *)
procedure enableParse(st: statementp);
var v: varidefp; b: boolean; i: integer;
begin
with st↑ do
begin
cmonlab := nil;
with curToken do
begin
getToken; (* get the label of the cmon to enable/disable *)
if ttype = identtype then (* check that it's really a label *)
begin
v := varLookup(id);
if v = nil then
begin (* need to define it *)
v := makeUVar(labeltype,id);
(* ??? where will we check that it gets used as a label ??? *)
cmonlab := v;
pp20L(' Undeclared identifi',20);
pp20('er defined to be a l',20); pp5('abel.',5); errprnt;
end
else if v↑.vtype = labeltype then cmonlab := v (* ok *)
else b := true (* no good *)
end
else
begin
i := cursor;
b := true; (* no good, unless in a cmon body *)
while (i > 1) and b do
with cursorStack[i] do
if stmntp then
if st↑.stype = cmtype then b := false (* found it *)
else i := i - 1
else i := i - 1;
end;
end;
if b then
begin (* no good *)
pp20L(' Need a label here. ',19); errprnt;
bad := true; (* mark statement as bad *)
end
else
bad := false; (* statement is ok *)
end;
end;
(* getBlkId, idGet & plistParse *)
function getBlkId: identp;
var bid: identp;
begin
bid := nil;
if curchar + 2 < maxchar then
begin
getToken; (* get the new block id *)
with curToken do
if ttype = constype then
begin
if cons↑.ltype = strngtype then
begin (* yup - grab the id string *)
bid := newIdent;
bid↑.length := cons↑.length;
bid↑.name := cons↑.str;
end
else
begin
pp20L(' Need a string here ',19); errprnt;
end;
relNode(cons);
end
else backup := true;
end;
getBlkId := bid;
end;
function idGet(st: statementp; indent,l: integer): ascii;
var id1,id2: identp; b: boolean; i,elen: integer; strg,strp: strngp;
sp: statementp; ch: ascii;
begin
with st↑ do
begin
if stype = coblocktype then
begin i := indent + 8; id1 := cblkid end
else
begin
if stype = endtype then i := indent + 4
else i := indent + 6;
id1 := blkid;
end;
if id1 = nil then elen := 0
else
begin
i := i + 1;
elen := id1↑.length;
strg := id1↑.name;
while strg <> nil do (* release old string *)
begin strp := strg↑.next; relStrng(strg); strg := strp end;
end;
if l > 0 then (* so addStmnt can use this *)
with lines[l]↑ do (* go edit it *)
ch := exprEditor(l-firstDline+1,start,length,i,elen,0)
else begin i := curChar + 1; elen := 1 end;
if id1 <> nil then
begin
curChar := i - 1;
maxChar := maxChar + 1;
relIdent(id1);
id1 := nil;
end;
if elen > 0 then id1 := getBlkId; (* get the new block id *)
if stype = coblocktype then
begin
cblkid := id1;
id2 := threads↑.cstmnt↑.next↑.blkid;
end
else
begin
blkid := id1;
if stype = blocktype then
begin
sp := bcode;
while sp↑.next <> nil do sp := sp↑.next; (* move to END *)
id2 := sp↑.blkid;
end
else id2 := bparent↑.blkid;
end;
if (id1 <> nil) and (id2 <> nil) then
begin (* now compare the two ids *)
b := id1↑.length = id2↑.length;
i := 3;
while listing[i] <> '"' do i := i + 1;
if b then b := eqStrng(id2↑.name,i+1,id1↑.length);
if not b then
begin
pp20L(' Block ids do not ma',20); pp5('tch ',3); errprnt;
end;
end;
end;
idGet := ch;
end;
function plistParse(st: statementp; e0,indent,l,ocur: integer): ascii;
var i,j,elen: integer; n,no,np: nodep; b,bp: boolean; ch: ascii;
begin
if fieldNum > 1 then
begin
no := st↑.plist;
for i := 1 to fieldNum-2 do no := no↑.next;
n := no↑.next
end
else
begin
n := st↑.plist;
if n = nil then e0 := e0 - 1;
no := nil
end;
b := true;
bp := false;
np := nil;
i := e0;
while b and (n <> nil) do
begin
j := i + getExprLength(n↑.lval);
if bp and (j > 78) then b := false
else
begin
bp := true;
np := n↑.next;
if np = nil then i := j else i := j+1; (* account for "," *)
relExpr(n↑.lval); (* flush the old expression *)
relNode(n); (* & the plist node too *)
n := np;
end
end;
elen := i - e0;
with lines[l]↑ do
ch := exprEditor(l-firstDline+1,start,length,e0,elen,0);
repeat
n := newNode;
n↑.ntype := listnode;
n↑.lval := exprParse; (* parse the modified exprs *)
if n↑.lval <> nil then
begin
if no = nil then st↑.plist := n else no↑.next := n;
no := n;
end
else relNode(n);
b := false;
getToken; (* check for "," or ")" *)
with curToken do (* *** should be smarter *** *)
begin
b := (ttype <> delimtype) or (ch <> ',');
if b and ((ttype = identtype) or
((ttype = reswdtype) and (rtype = optype))) then
begin
pp20L(' Inserting missing c',20); pp5('omma ',4); errprnt;
backup := true;
b := false;
end;
end;
until endOfLine or b;
if no = nil then st↑.plist := np else no↑.next := np;
with st↑ do
if plist = nil then exprs := nil else exprs := evalOrder(plist,nil,false);
reFormatStmnt(st,indent,ocur); (* may have changed nlines *)
plistParse := ch;
end;
(* labelParse & clabelParse *)
procedure labelParse;
var i: integer;
begin
cursorStack[cursor].st↑.stlab↑.s := nil; (* old label no longer points here *)
getToken; (* get new label *)
with curToken, cursorStack[cursor] do
if ttype = labeldeftype then
begin
st↑.stlab := lab;
lab↑.s := st;
end
else
begin (* delete the old label *)
st↑.stlab := nil;
deleteLines(cursorLine,1,0);
if (ttype <> delimtype) or (ch <> chr(CR)) or not endOfLine then
begin pp20L(' Expecting a label h',20); pp5('ere ',3); errprnt end;
end;
end;
procedure clabelParse(n: nodep);
var np: nodep;
begin
getToken;
with n↑, curToken do
if (ttype = delimtype) and (ch = '[') then
begin
np := checkArg(exprParse,svaltype); (* get constant value *)
if np↑.ntype <> leafnode then
begin
pp20L(' Must have constant ',20); pp5('here ',4); errprnt;
cval := -2;
end
else cval := round(np↑.s);
relExpr(np);
with cursorStack[cursor-1].st↑ do
if cval > -range then range := -cval;
getDelim(']');
end
else if (ttype = reswdtype) and (rtype = filtype) and
(filler = elsetype) then cval := -1
else
begin
(* *** maybe should recognize null line & delete the old label *** *)
pp20L(' Need a case number ',20); pp5('here.',5); errprnt;
cval := -2; (* use a garbage one *)
end
end;
(* aux routines: declarationp, getDeclarations & addNewDeclarations *)
function declarationp: boolean;
var b: boolean; v: varidefp;
begin
b := false;
getToken;
with curToken do
if ttype = reswdtype then
begin
if rtype = decltype then b := true
else if (rtype = optype) and ((op = vmakeop) or (op = vsaxwrop) or
(op = tmakeop) or (op = fmakeop)) then
begin
b := true;
rtype := decltype;
if op = vmakeop then decl := vectype
else if op = vsaxwrop then decl := rottype
else if op = tmakeop then decl := transtype else decl := frametype;
end
else if ((rtype = clsetype) and
((clause = forcetype) or (clause = torquetype) or
(clause = angularvelocitytype) or (clause = velocitytype))) then
begin
b := true;
ttype := identtype;
if clause = forcetype then id := forcedim↑.name
else if clause = torquetype then id := torquedim↑.name
else if clause = velocitytype then id := veldim↑.name
else id := angveldim↑.name;
end
end
else if ttype = identtype then
begin
v := varLookup(id);
if v <> nil then b := v↑.vtype = dimensiontype else b := false;
end;
if not b then backup := true;
declarationp := b;
end;
function dumDup(v: varidefp): boolean;
begin dumDup := false end; (* used by routines calling getDeclarations *)
function getDeclarations(pdef: boolean; lev: integer;
var vo: varidefp; var numvars: integer;
function dup(varidefp): boolean): varidefp;
(* *** Note: each Pascal compiler is apt to have its own syntax for passing *** *)
(* *** procedures/functions as a parameter. *** *)
var vhdr,va,vp,vdim: varidefp; off,tb,i: integer; d: datatypes;
endlist,b: boolean; no,n: nodep; idname: identp;
function badVarId: boolean;
var v: varidefp; b: boolean;
begin
b := true;
getToken; (* get the id name *)
if curToken.ttype <> identtype then
begin (* garbage *)
pp20L(' Expecting an identi',20); pp10('fier here ',9); errprnt;
backup := true;
b := false;
end
else if pdef then b := true
else
begin
v := curBlock↑.variables;
while (v <> nil) and b do
begin
if v↑.name = curToken.id then b := dup(v);
v := v↑.next;
end;
if not b then
begin (* it's already being used *)
pp20L(' Identifier previous',20); pp20('ly defined in curren',20);
pp10('t block. ',8); errprnt;
end
end;
badVarId := not b;
end;
procedure getSep;
begin
getToken; (* looking for "," or ";" or ")" *)
with curToken do
if ttype = delimtype then
begin
if ch = ',' then endlist := false (* more to get *)
else if pdef and (ch = ')') then backup := true
else if (ch <> ';') and (ch <> chr(CR)) then
begin
pp20L(' Expecting a "," or ',20); pp10('";" here ',8); errprnt;
end
end
else
begin
backup := true;
pp20L(' Inserting missing "',20);
if ttype = identtype then (* user defined dimension type? *)
begin
vp := varLookup(id);
if vp = nil then endlist := false
else if vp↑.vtype <> dimensiontype then endlist := false;
end;
if endlist then ppChar(';') else ppChar(',');
ppChar('"'); errprnt;
end
end;
begin
numvars := 0;
if vo = nil then off := 0 else off := vo↑.offset + 1;
vhdr := nil;
with curToken do
begin
flushcomments := true; (* don't allow comments here *)
b := true;
if pdef then
if (ttype = reswdtype) and (rtype = decltype) and
((decl = reftype) or (decl = valtype)) then
begin (* "reference" or "value" procedure args *)
if decl = valtype then tb := 0 else tb := 4;
b := declarationp; (* get dimension or base type *)
end
else tb := 4 (* pass by "reference" is the default *)
else tb := 0;
if (ttype = identtype) and b then
begin (* deal with dimension info *)
vdim := varLookup(id); (* save it for later *)
b := declarationp; (* get base datatype *)
end
else vdim := nil;
if (not b) or (ttype <> reswdtype) or (rtype <> decltype) or
(decl > arraytype) then
begin (* not a valid basic datatype *)
pp20L(' Need a basic dataty',20); pp10('pe here ',7); errprnt;
while (not endOfLine) and ((ttype <> delimtype) or (ch <> ';')) do
getToken; (* flush tokens *)
end
else
begin
if decl <> arraytype then d := decl
else
begin
d := undeftype; (* define it later *)
backup := true;
pp20L(' Need to specify bas',20); pp20('e type of array - wi',20);
pp20('ll try to define it ',20); pp5('later',5); errprnt;
end;
if d <> proctype then getToken; (* is this really an array or procedure? *)
if (ttype = reswdtype) and (rtype = decltype) and (decl = proctype) then
begin (* new procedure definition *)
if badVarId then idname := nil (* get proc's name & check it's ok *)
else idname := id;
vp := newVaridef;
if vhdr = nil then vhdr := vp;
if vo <> nil then vo↑.next := vp; (* add to list *)
vo := vp;
with vo↑ do
begin
next := nil;
dnext := nil;
name := idname;
level := lev;
offset := off;
off := off + 1;
numvars := numvars + 1;
tbits := 2;
if d = proctype then vtype := nulltype else vtype := d;
dtype := vdim;
n := newNode;
p := n;
end;
with n↑ do
begin
ntype := procdefnode;
ptype := vo↑.vtype;
level := lev + 1;
pname := vo;
paramlist := nil;
getToken; (* see if procedure has any parameters *)
if (ttype = delimtype) and (ch = '(') then (* yup - get 'em *)
begin
va := nil;
while declarationp do (* get parameters *)
begin
vdim := getDeclarations(true,level,va,i,dumDup);
if paramlist = nil then paramlist := vdim;
if (ttype = delimtype) and (ch = ';') then backup := false;
end;
va := paramlist;
while va <> nil do
with va↑ do begin dnext := next; va := next end;
flushcomments := true; (* don't allow comments again *)
getDelim(')'); (* look for closing ")" *)
getToken; (* get separating ";" *)
end;
backup := (ttype <> delimtype) or (ch <> ';');
body := newStatement;
getToken; (* sneak a look if there's a BEGIN block coming next *)
backup := true;
if (fParse and not sParse) or
((ttype = reswdtype) and (rtype = stmnttype) and
(curToken.stmnt = blocktype)) then (* make an empty stmnt now *)
begin
with body↑ do
begin stype := emptytype; blkid := nil; nlines := 1 end;
end
else
begin (* no body yet - make a Begin-End block *)
appendEnd(body,body);
with body↑ do
begin stype := blocktype; bparent := curBlock; blkid := nil;
nlines := 2; level := lev + 2; numvars := 0; bcode := next;
variables := nil end;
end;
body↑.next := newStatement; (* append a return, just in case *)
with body↑.next↑ do
begin
stype := returntype;
retval := nil;
exprs := nil;
last := n↑.body;
rproc := n;
end;
end;
end
else
begin
if (ttype = reswdtype) and (rtype = decltype) and (decl = arraytype) then
begin
tb := tb + 1; (* we've got an array specification *)
va := nil; (* for list of arrays sharing common bounds list *)
if pdef and (tb = 1) then
begin
tb := 5;
pp20L('Can''t pass arrays by',20); pp20(' value - changing to',20);
pp10(' reference',10); errprnt;
end
end
else
begin
backup := true;
if pdef and (tb = 0) and (d = eventtype) then
begin
tb := 4;
pp20L('Can''t pass events by',20); pp20(' value - changing to',20);
pp10(' reference',10); errprnt;
end
end;
if vdim <> nil then (* check that dimension applies to base type *)
if (d = rottype) and not matchdim(vdim↑.dim,angledim↑.dim,true) then
begin
vdim := nil;
pp20L(' Rotations must be o',20); pp20('f dimension ANGLE ',17);
errprnt;
end
else if (d = frametype) and
not matchdim(vdim↑.dim,distancedim↑.dim,true) then
begin
vdim := nil;
pp20L(' Frames must be of d',20); pp20('imension DISTANCE ',17);
errprnt;
end;
repeat
endlist := true; (* assume this is last one *)
if badVarId then
begin (* proc will complain if error *)
if not backup then getSep; (* skip over multiply defined idents *)
end
else
begin (* declare the new variable *)
vp := newVaridef;
if vhdr = nil then vhdr := vp;
if vo <> nil then
with vo↑ do begin next := vp; dnext := vp end; (* add to list *)
vo := vp;
if id↑.predefined <> nil then
if id↑.predefined↑.vtype = pconstype then
begin
pp20L('Redefining predeclar',20); pp20('ed constant - not a ',20);
pp10('good idea ',9); errprnt;
end;
with vp↑ do
begin
next := nil;
dnext := nil;
name := id;
level := lev;
offset := off;
off := off + 1;
numvars := numvars + 1;
tbits := tb;
vtype := d;
dtype := vdim;
if d = labeltype then s := nil;
end;
if odd(tb) then
begin (* look for array bounds *)
getToken; (* looking for a "[" *)
if (ttype <> delimtype) or (ch <> '[') then
begin (* not yet *)
backup := true;
vp↑.a := nil; (* no bounds info yet *)
if endOfLine or (ttype = delimtype) and (ch = ';') then
begin (* we aren't going to get one *)
if not pdef then
begin
pp20L(' Expecting an array ',20); pp20('bounds list here ',16);
errprnt;
vp↑.a := newNode;
with vp↑.a↑ do
begin
ntype := arraydefnode;
combnds := false;
numdims := 1;
bounds := newNode;
with bounds↑ do
begin
ntype := bnddefnode;
next := nil;
lower := defNode(svaltype);
lower↑.s := 1;
upper := defNode(svaltype);
upper↑.s := 10;
end;
end;
end
else va := nil;
end
else if va = nil then va := vp; (* so we can fill things in later *)
end
else
begin (* got one *)
vp↑.a := newNode;
vp↑.a↑.ntype := arraydefnode;
vp↑.a↑.combnds := false;
no := nil;
i := 0;
repeat
n := newNode;
i := i + 1;
with n↑ do
begin
ntype := bnddefnode;
next := nil;
lower := checkArg(exprParse,svaltype); (* get lower bound def *)
getDelim(':'); (* looking for separating ":" *)
upper := checkArg(exprParse,svaltype); (* get upper bound def *)
getToken; (* looking for final "]" or separating "," *)
if (ttype <> delimtype) or ((ch <> ',') and (ch <> ']')) then
begin
pp20L(' Expecting a "," or ',20); pp10('"]" here ',8); errprnt;
backup := true;
end;
if no = nil then vp↑.a↑.bounds := n else no↑.next := n;
no := n;
end
until ((ttype = delimtype) and ((ch = ']') or (ch = ';'))) or
(ttype = reswdtype) or endOfLine;
vp↑.a↑.numdims := i;
end;
if vp↑.a <> nil then (* now we can fill things in *)
while va <> nil do
begin
va↑.a := copyexpr(vp↑.a,false); (* copy bounds info *)
va := va↑.next;
if va↑.next = nil then va := nil; (* we already got this one *)
end
end;
getSep;
end
until endlist;
end
end;
flushcomments := false; (* comments are ok again *)
end;
backup := true;
getDeclarations := vhdr;
end;
function addNewDeclarations: integer;
var s,sp: statementp; i,j,l: integer;
begin
l := 0;
if newDeclarations <> nil then
begin (* deal with any new declarations *)
s := newDeclarations;
while s↑.stype <> blocktype do (* find block they're in *)
begin sp := s; s := s↑.last; l := l + sp↑.nlines end;
with s↑ do
begin
bcode↑.last := newDeclarations;
bcode := sp; (* splice us into block *)
end;
j := cursor;
i := 1;
while (j > i) do
with cursorStack[j] do
if stmntp and (st = s) then i := j
else begin cline := cline + l; j := j - 1; end;
with cursorStack[i] do
begin
if cline < lineNum then lineNum := lineNum + l;
if cline < topDline then
begin
topDline := topDline + l;
botDline := botDline + l;
for j := 1 to i do
with cursorStack[j] do (* update line counts *)
if stmntp then st↑.nlines := st↑.nlines + l;
end
else if cline < botDline then
begin
insertLines(cline+1,l,cursor-i);
curLine := cline; (* set up for putStmnt *)
firstLine := curLine + 1;
lastLine := curline + l;
s := s↑.bcode;
for j := 1 to l do
begin
if s↑.variables↑.vtype = undeftype then
begin
(* *** probably should ask the luser to define it, but... *** *)
s↑.variables↑.vtype := svaltype;
end;
(* *** especially need to ask for array bounds *** *)
(* *** & if procedure do something to set up a reasonable definition *** *)
putStmnt(s,ind,99); (* write out the declaration *)
makeNewVar(s↑.variables); (* if active block make env entry for var *)
s := s↑.next;
end;
putLine; (* force last line to be written out *)
end;
end;
cursorLine := cursorLine + l;
if ocur > 0 then ocur := ocur + l;
borderLines;
newDeclarations := nil;
end;
addNewDeclarations := l;
end;
(* aux routine: reParse *)
procedure reParse(st: statementp);
var i: integer; v: varidefp; lexp: nodep;
oCurChar, oMaxChar: integer; oEndOfLine, oBackup, ofParse: boolean;
abuf: packed array [1..160] of ascii; oCurToken: token;
procedure reParseAux(st: statementp);
var s: statementp; n,np: nodep; d: datatypes; b: boolean;
function reExpr(n,dim: nodep; d: datatypes): nodep;
var i: integer;
begin (* reExpr *)
if n <> nil then
begin
if (n↑.ntype = exprnode) or
((n↑.ntype = leafnode) and (n↑.ltype = varitype)) then
begin
lbufp := 0;
putExpr(n,0); (* write expression into lbuf *)
relExpr(n); (* flush old expression *)
for i := 1 to lbufp do (* copy expression for getToken *)
if lbuf[i] = chr(sailundline) then listing[i] := '_' (* for SAIL *)
else listing[i] := lbuf[i];
listing[lbufp+1] := ' ';
curChar := 1;
maxChar := lbufp + 1;
endOfLine := false;
backUp := false;
expandMacros := true;
n := exprParse; (* parse new expression *)
if n <> nil then
with n↑ do
if ntype = exprnode then elength := lbufp
else if (ntype = leafnode) and (ltype = svaltype) then wid := lbufp;
end;
if d <> nulltype then n := checkArg(n,d); (* datatype still ok? *)
if dim <> nil then dimCheck(n,dim); (* do dimensions still match? *)
end;
reExpr := n;
end (* reExpr *);
procedure reCmon(st: statementp); forward;
procedure reClause(n: nodep);
var d: datatypes; nv: nodep;
begin (* reClause *)
with n↑ do
case ntype of
deprnode,
apprnode,
destnode: begin
if ntype <> destnode then d := nulltype
else if st↑.stype = movetype then d := transtype
else d := svaltype;
loc := reExpr(loc,distancedim↑.dim,d);
reParseAux(code);
end;
viaptnode,
byptnode: begin
if st↑.stype = jtmovetype then
via := reExpr(via,nil,svaltype)
else if ntype = viaptnode then
via := reExpr(via,distancedim↑.dim,transtype)
else
begin
if st↑.stype = movetype then
begin
via := reExpr(via,distancedim↑.dim,nulltype);
if getdtype(via) <> vectype then via := checkArg(via,transtype);
end
else via := reExpr(via,distancedim↑.dim,svaltype);
end;
nv := vclauses;
while nv <> nil do
begin reClause(nv); nv := nv↑.next end;
reParseAux(code);
end;
durnode: begin
durval := reExpr(durval,timedim↑.dim,svaltype);
end;
velocitynode: begin
clval := reExpr(clval,nil,vectype);
end;
sfacnode,
wobblenode,
swtnode: begin
clval := reExpr(clval,nil,svaltype);
end;
ffnode: begin
ff := reExpr(ff,nil,transtype);
end;
forcenode: begin
fval := reExpr(fval,nil,svaltype);
fvec := reExpr(fvec,nil,vectype);
if fframe <> nil then reClause(fframe);
end;
stiffnode: begin
fv := reExpr(fv,nil,vectype);
mv := reExpr(mv,nil,vectype);
if cocff <> nil then reClause(cocff);
end;
cmonnode: begin
reCmon(cmon);
end;
others: begin end; (* nothing to do *)
end;
end (* reClause *);
procedure reCmon (* st: statementp *);
begin (* reCmon *)
with st↑, oncond↑ do
begin
if (ntype = durnode) or (ntype = forcenode) then reClause(oncond)
else if (ntype = exprnode) or (ntype = leafnode) then
begin
oncond := reExpr(oncond,nil,nulltype);
exprCm := getDtype(oncond) <> eventtype;
end;
if exprCm or (ntype = durnode) or (ntype = forcenode) then
exprs := evalOrder(oncond,nil,true)
else if ntype = exprnode then (* subscripted event *)
exprs := evalOrder(arg2,nil,true)
else exprs := nil;
reParseAux(conclusion);
end;
end (* reCmon *);
begin (* reParseAux *)
if st <> nil then
with st↑ do
case stype of
blocktype: begin
pushStmnt(st,0); (* for var lookup *)
s := bcode;
while s <> nil do begin reParseAux(s); s := s↑.next end;
cursor := cursor - 1;
end;
declaretype: begin
with variables↑ do
if tbits = 2 then (* check for procedure *)
begin
pushNode(p); (* for var lookup *)
reParseAux(p↑.body);
cursor := cursor - 1;
end;
end;
coblocktype: begin
n := threads;
while n <> nil do begin reParseAux(n↑.cstmnt); n := n↑.next end;
end;
fortype: begin
forvar := reExpr(forvar,nil,svaltype);
n := nil;
n := getdim(forvar,n);
if bad and
(((forvar↑.ntype = leafnode) and (forvar↑.ltype = varitype)) or
((forvar↑.ntype = exprnode) and (forvar↑.op = arefop))) then
bad := false; (* ok now *)
initial := reExpr(initial,n,svaltype);
step := reExpr(step,n,svaltype);
final := reExpr(final,n,svaltype);
relNode(n);
reParseAux(fbody);
with forvar↑ do
if ntype = leafnode then n := nil
else n := evalOrder(arg2,nil,true); (* push array subscripts *)
n := evalOrder(initial,n,true);
n := evalOrder(step,n,true);
exprs := evalOrder(final,n,true);
end;
whiletype,
untiltype: begin
cond := reExpr(cond,nil,svaltype);
exprs := evalOrder(cond,nil,true);
reParseAux(body);
end;
casetype: begin
index := reExpr(index,nil,svaltype);
exprs := evalOrder(index,nil,true);
n := caselist;
s := nil;
while n <> nil do
begin
if n↑.stmnt <> s then reParseAux(n↑.stmnt);
s := n↑.stmnt;
n := n↑.next;
end;
end;
iftype: begin
icond := reExpr(icond,nil,svaltype);
exprs := evalOrder(icond,nil,true);
reParseAux(thn);
reParseAux(els);
end;
pausetype: begin
ptime := reExpr(ptime,timedim↑.dim,svaltype);
exprs := evalOrder(ptime,nil,true);
end;
printtype,
prompttype,
aborttype,
saytype: begin
n := plist;
while n <> nil do
begin
n↑.lval := reExpr(n↑.lval,nil,nulltype);
n := n↑.next;
end;
exprs := evalOrder(plist,nil,false);
end;
returntype: begin (*** * should check what procedure wants *** *)
retval := reExpr(retval,nil,nulltype);
exprs := evalOrder(retval,nil,true);
end;
calltype: begin
what := reExpr(what,nil,nulltype);
exprs := evalOrder(what,nil,true);
end;
assigntype: begin
what := reExpr(what,nil,nulltype);
(* *** should check that what is ok for assignment & set bad accordingly *** *)
n := nil;
n := getDim(what,n);
d := getDtype(what);
if d = frametype then d := transtype;
aval := reExpr(aval,n,d);
relNode(n);
with what↑ do
if ntype = leafnode then n := nil
else if op = arefop then n := arg2
else if arg1↑.ntype = leafnode then n := nil
else n := arg1↑.arg2;
if n <> nil then
n := evalorder(n,nil,true); (* deal with subscripts *)
exprs := evalorder(aval,n,true);
end;
affixtype,
unfixtype: begin
frame1 := reExpr(frame1,nil,frametype);
frame2 := reExpr(frame2,nil,frametype);
byvar := reExpr(byvar,distancedim↑.dim,transtype);
atexp := reExpr(atexp,distancedim↑.dim,transtype);
b := bad; (* if bad see if we just corrected error *)
if b and (((frame1↑.ntype = leafnode) and (frame1↑.ltype<>varitype))
or ((frame1↑.ntype = exprnode) and (frame1↑.op=badop))) then
b := false; (* still bad *)
if b and (((frame2↑.ntype = leafnode) and (frame2↑.ltype<>varitype))
or ((frame2↑.ntype = exprnode) and (frame2↑.op=badop))) then
b := false; (* still bad *)
if b and (byvar <> nil) then
if ((byvar↑.ntype = leafnode) and (byvar↑.ltype <> varitype)) or
((byvar↑.ntype = exprnode) and (byvar↑.op = badop)) then
b := false; (* still bad *)
if b then bad := false; (* it's ok now *)
with frame1↑ do
if ntype = leafnode then n := nil
else n := evalOrder(arg2,nil,true); (* push array subscripts *)
with frame2↑ do
if ntype <> leafnode then n := evalOrder(arg2,n,true);
if byvar <> nil then
with byvar↑ do
if ntype <> leafnode then n := evalOrder(arg2,n,true);
if atexp <> nil then exprs := evalOrder(atexp,n,true)
else exprs := n;
end;
signaltype,
waittype: begin
event := reExpr(event,nil,eventtype);
if event↑.ntype <> leafnode then exprs := nil
else exprs := evalOrder(event↑.arg2,nil,true);
end;
movetype,
jtmovetype,
operatetype,
opentype,
closetype,
centertype,
floattype,
setbasetype,
stoptype: begin
pushStmnt(st,0); (* so grinch can be parsed *)
if bad and ((stype = movetype) or (stype = jtmovetype))
and (cf <> nil) then
if (((cf↑.ntype = leafnode) and (cf↑.ltype = varitype)) or
((cf↑.ntype = exprnode) and (cf↑.op = arefop))) then
bad := false; (* it's ok now *)
cf := reExpr(cf,nil,nulltype);
n := clauses;
while n <> nil do
begin reClause(n); n := n↑.next end;
moveOrder(st);
cursor := cursor - 1;
end;
cmtype: begin
reCmon(st);
end;
wristtype: begin
fvec := reExpr(fvec,forcedim↑.dim,vectype);
tvec := reExpr(tvec,torquedim↑.dim,vectype);
ff := reExpr(ff,nil,frametype);
arm := reExpr(arm,nil,frametype);
if bad and
((((fvec↑.ntype = leafnode) and (fvec↑.ltype = varitype)) or
((fvec↑.ntype = exprnode) and (fvec↑.op = arefop))) and
(((tvec↑.ntype = leafnode) and (tvec↑.ltype = varitype)) or
((tvec↑.ntype = exprnode) and (tvec↑.op = arefop)))) then
bad := false; (* it's ok now *)
n := nil;
if arm <> nil then
with arm↑ do
if (ntype = exprnode) and (op = arefop) then
n := evalorder(arg2,n,true); (* deal with subscripts *)
if ff <> nil then
n := evalorder(ff,n,true); (* push wrist frame *)
with fvec↑ do
if (ntype = exprnode) and (op = arefop) then
n := evalorder(arg2,n,true); (* deal with subscripts *)
with tvec↑ do
if (ntype = exprnode) and (op = arefop) then
n := evalorder(arg2,n,true); (* deal with subscripts *)
exprs := n;
end;
armmagictype: begin
cmdnum := reExpr(cmdnum,nil,svaltype);
dev := reExpr(dev,nil,nulltype);
if dev = nil then b := true
else
with dev↑ do (* make sure it's a variable *)
begin
b := (ntype <> leafnode) or (ltype <> varitype);
if b then b := (ntype <> exprnode) or (op <> arefop);
end;
bad := b; (* mark statement as bad *)
n := iargs;
while n <> nil do
begin
n↑.lval := reExpr(n↑.lval,nil,nulltype);
n := n↑.next;
end;
n := oargs;
while n <> nil do
begin (* make sure each entry in result list is a variable *)
n↑.lval := reExpr(n↑.lval,nil,nulltype);
with n↑.lval↑ do
begin
b := (ntype <> leafnode) or (ltype <> varitype);
if b then b := (ntype <> exprnode) or (op <> arefop);
if b then bad := true;
end;
n := n↑.next;
end;
if not bad then
begin (* set up exprs field *)
lexp := evalOrder(cmdnum,nil,true);
if dev <> nil then (* evaluate device *)
if dev↑.ntype <> leafnode then (* push array subscripts *)
lexp := evalOrder(dev↑.arg2,nil,true);
lexp := evalOrder(iargs,lexp,true); (* push input arguments *)
n := oargs;
while n <> nil do
with n↑ do
begin (* push any subscripts in result list *)
if lval↑.ntype = exprnode then
lexp := evalOrder(n↑.lval,lexp,true);
n := next;
end;
exprs := lexp;
end;
end;
others: begin (* nothing to do *)
end;
end;
end (* reParseAux *);
procedure copyTok(var a,b: token);
begin
with b do (* copy a := b *)
begin
a.next := next;
a.ttype := ttype;
if ttype = constype then a.cons := cons
else
begin
a.rtype := rtype;
a.len := len; (* this should work ... *)
a.str := str;
end;
end;
end;
begin (* reParse *)
for i := 1 to 160 do abuf[i] := listing[i]; (* save listing array *)
oCurChar := curChar; (* also save other state info *)
oMaxChar := maxChar;
oEndOfLine := endOfLine;
oBackup := backup;
if backup then copyTok(oCurToken,curToken);
ofParse := fParse;
fParse := false;
if not ofParse then begin pp20L('Need to reparse... ',18); ppLine end;
if st↑.stype = blocktype then
begin
v := st↑.variables; (* need to push any array bounds info *)
lexp := nil;
while v <> nil do
begin
if v↑.tbits = 1 then lexp := evalOrder(v↑.a↑.bounds,lexp,false);
v := v↑.next;
end;
st↑.exprs := lexp;
end;
reParseAux(st);
lbufp := 0;
if not sParse then i := addNewDeclarations;
topDline := 0; (* flush old display *)
botDline := 0;
if not ofParse then displayLines(lineNum); (* & redraw it *)
for i := 1 to 160 do listing[i] := abuf[i]; (* restore listing array *)
curChar := oCurChar; (* also restore other state info *)
maxChar := oMaxChar;
endOfLine := oEndOfLine;
backup := oBackup;
if backup then copyTok(curToken,oCurToken);
fParse := ofParse;
end (* reParse *);
(* varParse & procParse *)
function varParse(st: statementp; indent,l: integer): ascii;
var b,reparsep: boolean; i,j,elen,onumvars: integer; ch: ascii;
v,vhdr,vp,vo: varidefp;
oldvars,newvars: array [1..40] of varidefp; (* 40 should be more than enough... *)
function dupCheck(vo: varidefp): boolean; (* used by getDeclarations *)
var i: integer; b: boolean;
begin
b := false; (* assume no match *)
for i := 1 to onumvars do
if oldvars[i] <> nil then
if vo↑.name = oldvars[i]↑.name then b := true; (* found it? *)
dupCheck := b;
end;
begin
v := st↑.variables;
onumvars := 0;
while v <> nil do
begin (* save pointers to old variable defs *)
onumvars := onumvars + 1;
oldvars[onumvars] := v;
v := v↑.dnext;
end;
(* *** might check if variable was previously undefined, but now is defined
& if so update line on screen with correct info *** *)
with lines[l]↑ do
begin (* edit it *)
elen := length - indent + 1;
if listing[start+length-1] = ';' then begin elen := elen - 1; b := true end
else b := false;
ch := exprEditor(l-firstDline+1,start,length,indent,elen,0);
end;
if b then maxChar := maxChar + 1;
if not declarationp then
begin
pp20L(' Need a declaration ',20); pp5('here ',4); errprnt;
end
else
begin
vhdr := getDeclarations(false,curBlock↑.level,v,i,dupCheck);
st↑.numvars := i; (* remember # of variables *)
reparsep := false;
v := vhdr;
for i := 1 to st↑.numvars do
begin (* see if old or new variable *)
j := 0;
b := false;
repeat
j := j + 1;
if oldvars[j] <> nil then b := v↑.name = oldvars[j]↑.name;
until b or (j >= onumvars);
if b then
begin (* an old one *)
with oldvars[j]↑ do (* note any changes *)
begin
if dtype <> v↑.dtype then (* see if dimension has changed *)
begin dtype := v↑.dtype; reparsep := true end;
if vtype <> v↑.vtype then (* see if base type has changed *)
begin
vtype := v↑.vtype;
reparsep := true;
(* *** if active block need to change environment entry for variable *** *)
end;
if odd(tbits) then
if a↑.combnds then relNode(a) (* free up any old array bounds *)
else relExpr(a);
if tbits <> v↑.tbits then (* ditto for tbits *)
begin tbits := v↑.tbits; reparsep := true end;
if odd(tbits) then
begin
a := v↑.a; (* copy new array bounds *)
(* *** if active block need to re-evaluate array bounds
& maybe change array size *** *)
end
else if tbits = 2 then
begin (* need to do special stuff for procedure??? *)
p := v↑.p; (* *** deal with proc def ??? *** *)
(* *** if active block need to change environment entry for variable *** *)
end;
end;
newvars[i] := oldvars[j];
oldvars[j] := nil;
end
else
begin (* a new one *)
newvars[i] := makeNVar(v↑.vtype,v↑.name);
with newvars[i]↑ do
begin (* copy relevant fields *)
dtype := v↑.dtype;
tbits := v↑.tbits;
if odd(tbits) then a := v↑.a (* copy array bounds *)
else if tbits = 2 then
begin (* need to do special stuff for procedure??? *)
p := v↑.p; (* *** deal with proc def ??? *** *)
p↑.pname := vp;
end;
end;
makeNewVar(newvars[i]); (* if active block need to make env entry for var *)
reparsep := true;
end;
vp := v↑.dnext;
relVaridef(v); (* all done with the duplicate varidef now *)
v := vp;
if i > 1 then newvars[i-1]↑.dnext := newvars[i];
end;
if st↑.numvars > 0 then
begin
newvars[st↑.numvars]↑.dnext := nil;
st↑.variables := newvars[1];
end
else
begin (* flush declaration *)
with st↑.last↑ do (* splice us out of list *)
if st↑.stype = blocktype then bcode := st↑.next
else next := st↑.next;
st↑.next↑.last := st↑.last;
cursorStack[cursor].st := st↑.next;
deleteLines(cursorLine,1,1);
relStatement(st);
end;
for i := 1 to onumvars do
if oldvars[i] <> nil then
begin reparsep := true; flushVar(oldvars[i]) end;
if reparsep then
begin (* need to reparse block *)
reParse(curBlock);
end;
end;
varParse := ch;
end;
function procParse(n: nodep; indent,l: integer): ascii;
var b,reparsep: boolean; i,j,elen,numvars,onumvars,off: integer; ch: ascii;
v,vhdr,vp: varidefp; d: datatypes;
oldvars,newvars: array [1..40] of varidefp; (* 40 should be more than enough... *)
begin
v := n↑.paramlist;
onumvars := 0;
off := 0;
while v <> nil do
begin (* save pointers to old variable defs *)
onumvars := onumvars + 1;
oldvars[onumvars] := v;
if v↑.offset > off then off := v↑.offset; (* find offset for new vars *)
v := v↑.dnext;
end;
(* *** might check if procedure was previously undefined, but now is defined
& if so update line on screen with correct info *** *)
with lines[l]↑ do
begin (* edit it *)
elen := length - indent;
ch := exprEditor(l-firstDline+1,start,length,indent,elen,0);
end;
maxChar := maxChar + 1;
reparsep := false;
with curToken do
begin
flushcomments := true; (* don't allow comments here *)
b := declarationp; (* get the base type *)
if (ttype = identtype) and b then
begin (* deal with dimension info *)
v := varLookup(id); (* save it for later *)
b := declarationp; (* get base datatype *)
end
else v := nil;
if v <> n↑.pname↑.dtype then (* has the dimension changed? *)
begin n↑.pname↑.dtype := v; reparsep := true end;
if (not b) or (ttype <> reswdtype) or (rtype <> decltype) then
begin (* not a valid basic datatype *)
pp20L(' Need a basic dataty',20); pp10('pe here ',7); errprnt;
end
else
begin
if decl = proctype then d := nulltype else d := decl;
if d <> n↑.pname↑.vtype then (* same base type? *)
begin n↑.pname↑.vtype := d; reparsep := true end;
end;
if d <> nulltype then getToken; (* get procedure token *)
if (ttype <> reswdtype) or (rtype <> decltype) or (decl <> proctype) then
begin
pp20L(' Expecting "procedur',20); pp20('e" here - good luck!',20); errprnt;
backup := true; (* *** maybe should do something smart here??? *** *)
end;
getToken; (* get the procedure's name *)
if ttype <> identtype then
begin (* garbage *)
pp20L(' Expecting an identi',20); pp10('fier here ',9); errprnt;
backup := true;
end
else if n↑.pname↑.name <> id then
begin (* change the procedure's name *)
n↑.pname↑.name := id; (* *** for now change name & all references to it *** *)
reparsep := true;
end;
getToken; (* see if any parameters *)
numvars := 0;
n↑.paramlist := nil;
if (ttype = delimtype) and (ch = '(') then (* yup - get 'em *)
begin
v := nil;
j := n↑.pname↑.level + 1;
while declarationp do (* get parameters *)
begin
vhdr := getDeclarations(true,j,v,i,dumDup);
numvars := numvars + i; (* remember # of parameters *)
if n↑.paramlist = nil then n↑.paramlist := vhdr;
if (ttype = delimtype) and (ch = ';') then backup := false;
end;
flushcomments := true; (* don't allow comments again *)
getDelim(')'); (* look for closing ")" *)
end;
end;
v := n↑.paramlist;
for i := 1 to numvars do
begin (* see if old or new variable *)
j := 0;
b := false;
repeat
j := j + 1;
if oldvars[j] <> nil then b := v↑.name = oldvars[j]↑.name;
until b or (j >= onumvars);
if b then
begin (* an old one *)
with oldvars[j]↑ do (* note any changes *)
begin
if dtype <> v↑.dtype then (* see if dimension has changed *)
begin dtype := v↑.dtype; reparsep := true end;
if vtype <> v↑.vtype then (* see if base type has changed *)
begin
vtype := v↑.vtype;
reparsep := true;
(* *** if active procedure need to change environment entry for variable *** *)
end;
if odd(tbits) then relExpr(a); (* free up any old array bounds *)
if tbits <> v↑.tbits then (* ditto for tbits *)
begin tbits := v↑.tbits; reparsep := true end;
if odd(tbits) then
begin
a := v↑.a; (* copy new array bounds *)
end;
end;
newvars[i] := oldvars[j];
oldvars[j] := nil;
vp := v↑.next;
relVaridef(v); (* all done with the duplicate varidef now *)
v := vp;
end
else
begin (* a new one *)
newvars[i] := v;
off := off + 1;
v↑.offset := off;
(* *** if active procedure need to create environment entry for variable *** *)
reparsep := true;
v := v↑.next;
end;
if i > 1 then
with newvars[i-1]↑ do begin next := newvars[i]; dnext := next end;
end;
if numvars > 0 then
begin
newvars[numvars]↑.next := nil;
newvars[numvars]↑.dnext := nil;
n↑.paramlist := newvars[1];
(* if not active-now then *)
begin (* renumber variable offsets *)
for i := 1 to numvars - 1 do
with newvars[i]↑ do
begin
next := newvars[i+1];
offset := i-1;
end;
newvars[numvars]↑.next := nil;
end;
end
else n↑.paramlist := nil;
for i := 1 to onumvars do
if oldvars[i] <> nil then
with oldvars[i]↑ do
begin (* flush old unused variables *)
(* *** if active procedure flush its value *** *)
if odd(tbits) then relExpr(a); (* free up old array bounds list *)
relVaridef(oldvars[i]);
reparsep := true;
end;
if reparsep then
begin (* need to reparse procedure body *)
reParse(n↑.body);
end;
procParse := ch;
end;
(* aux functions for motion clauses: thenCode, getcsys & clauseParse *)
function thenCode(evp: boolean; s: statementp): statementp;
var st: statementp; n: nodep; v: varidefp;
begin
if s↑.stype = signaltype then st := s (* treat signal specially *)
else
begin
st := newStatement;
with st↑ do (* make a cmon to execute the code *)
begin
stype := cmtype;
deferCm := false;
exprCm := false;
conclusion := s;
appendEnd(st,s);
n := newNode;
oncond := n;
end;
v := makeNVar(cmontype,nil); (* make a variable for the cmon *)
v↑.s := st;
st↑.cdef := v;
if evp then (* do we need to make an event variable? *)
begin
with n↑ do
begin
ntype := leafnode;
ltype := varitype;
vari := makeNVar(eventtype,nil);
makeNewVar(vari); (* if active block deal with environment entry *)
vid := nil;
end;
end;
makeNewVar(v); (* if active block deal with environment entry *)
end;
thenCode := st;
end;
function getcsys(defcsys: boolean): boolean; (* aux routine *)
var b: boolean;
begin
b := defcsys;
with curToken do
if (ttype = reswdtype) and (rtype = filtype) and (filler = intype) then
begin (* see whether WORLD or HAND coord sys *)
getToken;
if (ttype = reswdtype) and (rtype = filtype) and
((filler = worldtype) or (filler = handtype)) then b := (filler=worldtype)
else
begin
backup := true;
pp20L(' Need HAND or WORLD ',20); pp5('here ',4); errprnt;
end
end
else backup := true;
getcsys := b;
end;
function clauseParse(n: nodep; absSeen: boolean): nodep;
var cl,nv,vdim: nodep; b,bp,badcl: boolean; dummyrel: reltypes;
bits,i: integer; d: datatypes; fch: char;
function relParse: reltypes;
begin
getToken; (* get the relation *)
with curToken do
if (ttype = reswdtype) and (rtype = optype) and (op <= sgtop) then
relParse := op
else
begin
pp20L(' Need a relational o',20); pp20('perator here ',12); errprnt;
backup := true;
relParse := seqop;
end;
end;
begin
getToken;
if n = nil then cl := newNode else cl := n;
badcl := false;
with curToken, cl↑ do
begin
if ttype = identtype then
begin
if id↑.name↑.ch = 'SPEED_FACT' then
begin (* should also really check for final "OR" of speed_factor, but... *)
ntype := sfacnode;
dummyrel := relParse; (* skip over the "=" *)
clval := checkArg(exprParse,svaltype);
dimCheck(clval,nodim↑.dim);
end
else badcl := true (* any other identifier is an error *)
end
else if (ttype = reswdtype) and (rtype = filtype) then
begin
if filler = notype then
begin
getToken; (* look for NULLING or FLIP *)
notp := true;
if (ttype <> reswdtype) or (rtype <> clsetype) or
((clause <> nullingtype) and (clause <> fliptype)) then
begin
pp20L('Expecting "NULLING" ',20); pp20('or "FLIP" here ',14);
badcl := true; (* no good *)
end;
if clause = fliptype then ntype := flipnode else ntype := nullingnode;
end
else if (filler = righttype) or (filler = lefttype) then
begin
ntype := shouldernode;
notp := filler = righttype;
getToken; (* look for SHOULDER *)
if (ttype <> reswdtype) or (rtype <> clsetype) or
(clause <> shouldertype) then
begin
pp20L('Expecting "SHOULDER"',20); pp5(' here',5);
badcl := true; (* no good *)
end;
end
else badcl := true (* any other filler is an error *)
end
else if (ttype <> reswdtype) or (rtype <> clsetype) then badcl := true
else
case clause of
durationtype:
begin
ntype := durnode;
durrel := relParse;
durval := checkArg(exprParse,svaltype);
dimCheck(durval,timedim↑.dim);
end;
velocitytype:
begin
ntype := velocitynode;
dummyrel := relParse;
clval := checkArg(exprParse,vectype);
dimCheck(clval,veldim↑.dim);
end;
wobbletype,
stopwaittimetype:
begin
if clause = wobbletype then
begin
ntype := wobblenode;
vdim := angledim↑.dim;
end
else
begin
ntype := swtnode;
vdim := timedim↑.dim;
end;
dummyrel := relParse;
clval := checkArg(exprParse,svaltype);
dimCheck(clval,vdim);
end;
fliptype,
nullingtype:
begin
if clause = fliptype then ntype := flipnode else ntype := nullingnode;
notp := false;
end;
elbowtype:
begin
ntype := elbownode;
getToken; (* see if it's UP or DOWN *)
if (ttype <> reswdtype) or (rtype <> filtype) or
((filler <> uptype) and (filler <> downtype)) then
begin
pp20L('Expecting "UP" or "D',20); pp10('OWN" here ',9); errprnt;
backup := true;
end;
notp := filler = uptype;
end;
lineartype,
jointspacetype:
begin
ntype := linearnode;
if clause = lineartype then notp := true else notp := false;
getToken; (* get MOTION token *)
if (ttype <> reswdtype) or (rtype <> filtype) or
(filler <> motiontype) then
begin
pp20L('Expecting "MOTION" h',20); pp5('ere ',3); errprnt;
backup := true;
end;
end;
cwtype,
ccwtype:
begin
ntype := cwnode;
if clause = cwtype then notp := false else notp := true;
end;
approachtype,
departuretype:
begin
if clause = approachtype then ntype := apprnode else ntype := deprnode;
dummyrel := relParse;
getToken; (* check for NILDEPROACH *)
if (ttype = reswdtype) and
(rtype = clsetype) and (clause = nildeproachtype) then loc := nil
else
begin (* need to get deproach value *)
backup := true;
loc := exprParse; (* can be scalar, vector or trans *)
dimCheck(loc,distancedim↑.dim);
end;
code := nil;
(* *** what about THEN ??? *** *)
end;
forcewristtype:
begin
ntype := wristnode;
getToken;
if (ttype = reswdtype) and (rtype = optype) and
(curToken.op = notop) then
begin
notp := true;
getToken;
end
else notp := false;
if (ttype <> reswdtype) or (rtype <> filtype) or
(filler <> zeroedtype) then
begin
backup := true;
pp20L(' Garbage clause ',15); errprnt;
end
end;
forceframetype:
begin
ntype := ffnode;
if not absSeen then dummyrel := relParse;
ff := checkArg(exprParse,transtype);
dimCheck(ff,distancedim↑.dim);
getToken;
csys := getcsys(true); (* use WORLD as default coord sys *)
end;
forcetype,
torquetype,
angularvelocitytype:
begin
ntype := forcenode;
if clause = forcetype then
begin ftype := force; vdim := forcedim↑.dim end
else if clause = torquetype then
begin ftype := torque; vdim := torquedim↑.dim end
else begin ftype := angvelocity; vdim := angveldim↑.dim end;
if absSeen then ftype := succ(ftype);
getToken;
if (ttype = delimtype) and (ch = '(') then (* short form *)
begin
b := true;
fvec := checkArg(exprParse,vectype);
getDelim(')'); (* get closing ")" *)
getToken;
end
else b := false; (* long form *)
if absSeen then
begin
if (ttype <> reswdtype) or (rtype <> optype) or
(curToken.op <> absop) then
begin
backup := true;
pp20L(' Need closing "|" he',20); pp5('re ',2); errprnt;
end;
end
else backup := true;
frel := relparse;
fval := checkArg(exprParse,svaltype);
dimCheck(fval,vdim);
i := cursor;
bp := true;
while (i > 2) and bp do
with cursorStack[i] do
if stmntp and (movetype <= st↑.stype) and (st↑.stype <= floattype)
then bp := false else i := i - 1;
with cursorStack[i].st↑ do
if (stype = opentype) or (stype = closetype) or (stype = operatetype) then
begin
b := true; (* so we don't look for a vector specification *)
cl↑.fvec := nil;
end;
if not b then
begin
getToken;
if (ttype <> reswdtype) or (rtype <> filtype) or
((filler <> abouttype) and (filler <> alongtype)) then
begin
backup := true;
pp20L(' Need ALONG or ABOUT',20); pp5(' here',5);
end;
fvec := checkArg(exprParse,vectype);
end;
getToken; (* check for force frame *)
backup := true;
if (ttype = reswdtype) and (rtype = filtype) and (filler = oftype) then
begin
rtype := clsetype; (* make curToken look like forceframe clause *)
clause := forceframetype;
fframe := clauseParse(nil,true);
end
else fframe := nil;
end;
stiffnesstype:
begin
ntype := stiffnode;
dummyrel := relParse; (* skip over the "=" *)
getDelim('('); (* now look for the "(" *)
fv := exprParse; (* get the first stiffness component *)
if getDtype(fv) = svaltype then (* see if it's 6 scalars or 2 vectors *)
for i := 1 to 2 do
begin
nv := newNode;
with nv↑ do
begin
ntype := exprnode;
op := vmakeop;
if i = 2 then arg1 := checkArg(exprParse,svaltype)
else arg1 := cl↑.fv;
getDelim(',');
arg2 := checkArg(exprParse,svaltype);
getDelim(',');
arg3 := checkArg(exprParse,svaltype);
end;
if i = 1 then begin fv := nv; getDelim(',') end else mv := nv;
end
else
begin (* two vectors *)
fv := checkArg(fv,vectype);
getDelim(','); (* now look for the separating "," *)
mv := checkArg(exprParse,vectype);
end;
dimCheck(fv,fvstiffdim);
dimCheck(mv,mvstiffdim);
getDelim(')'); (* now look for the ")" *)
getToken; (* is a center of compliance given? *)
backup := true;
if (ttype = reswdtype) and (rtype = filtype) and (filler = abouttype) then
begin
rtype := clsetype; (* make curToken look like forceframe clause *)
clause := forceframetype;
cocff := clauseParse(nil,true);
end
else cocff := nil;
end;
gathertype:
begin
ntype := gathernode;
dummyrel := relParse; (* skip over the "=" *)
getDelim('('); (* now look for the "(" *)
gbits := 0;
repeat
bits := 0;
getToken; (* get component to gather *)
if ttype = identtype then
if id↑.length = 2 then
with id↑.name↑ do
begin
if (ch[1] = 'F') or (ch[1] = 'M') then
begin
if ('X' <= ch[2]) and (ch[2] <= 'Z') then
begin
case ch[2] of
'X': bits := 1; (* fx = 1B mx = 10B *)
'Y': bits := 2; (* fy = 2B my = 20B *)
'Z': bits := 4; (* fz = 4B mz = 40B *)
end;
if ch[1] = 'M' then bits := bits * 8;
end
end
else if (ch[1] = 'T') and ('1' <= ch[2]) and (ch[2] <= '6') then
case ch[2] of
'1': bits := (*100B *) 64;
'2': bits := (*200B *) 128;
'3': bits := (*400B *) 256;
'4': bits := (*1000B*) 512;
'5': bits := (*2000B*) 1024;
'6': bits := (*4000B*) 2048;
end;
end
else if id↑.name↑.ch = 'TBL ' then bits := (*10000B*) 4096;
b := bits = 0; (* bad clause *)
gbits := gbits + bits; (* really need to logically OR these *)
if b then
begin
pp20L(' Expecting a force c',20); pp20('omponent here ',13);
errprnt;
if ttype = identtype then getToken; (* skip past bad identifier *)
end
else getToken; (* pick up the "," or ")" *)
until (ttype <> identtype) and ((ttype <> delimtype) or (ch <> ','));
backup := true;
getDelim(')'); (* now look for the ")" *)
end;
loadtype:
begin
ntype := loadnode;
dummyrel := relParse; (* skip over the "=" *)
loadval := checkArg(exprParse,svaltype);
dimCheck(loadval,forcedim↑.dim);
getToken;
if (ttype = reswdtype) and (rtype = filtype) and (filler = attype) then
begin
loadvec := checkArg(exprParse,vectype);
getToken;
end;
lcsys := getcsys(false); (* default is HAND *)
end;
end;
end;
if badcl then
begin
if n = nil then begin relNode(cl); cl := nil; end;
backup := true;
pp20L(' Not a valid clause ',19); errprnt;
end;
clauseParse := cl;
end;
(* cmonParse *)
procedure cmonParse(st: statementp; getStart: boolean);
var inMove: boolean; i: integer; t: tokenp;
begin
with cursorStack[cursor-1] do
inMove := (not stmntp) and (nd↑.ntype = cmonnode);
with st↑, curToken do
begin
if oncond <> nil then
with oncond↑ do (* see what sort of cmon we were & release any old fields *)
if ntype = durnode then begin relExpr(durval); relNode(oncond) end
else if ntype = forcenode then
begin relExpr(fval); relExpr(fvec); relExpr(fframe); relNode(oncond) end
else if ntype = errornode then
begin
relExpr(eexpr); relNode(oncond);
if inMove then cursorStack[cursor-1].nd↑.errhandlerp := false;
end
else relExpr(oncond);
exprCm := false;
oncond := nil;
exprs := nil;
getToken; (* see what sort of cmon we are now *)
if getStart then
begin
deferCm := false;
if (ttype = reswdtype) and (rtype = filtype) and (filler = defertype) then
begin
deferCm := true;
getToken;
end;
if (ttype <> reswdtype) or (rtype <> stmnttype) or (stmnt <> cmtype) then
begin
pp20L(' Expecting an "ON" h',20); pp5('ere ',3); errprnt;
end
else getToken;
end;
if (ttype = reswdtype) and (rtype = clsetype) then
begin
if (clause = durationtype) or (clause = forcetype) or (clause = torquetype) then
begin
backup := true;
oncond := clauseParse(nil,false);
end
else if (clause = arrivaltype) or (clause = departingtype) then
begin
if inMove then
begin
st↑.oncond := newNode;
with st↑.oncond↑ do
if clause = arrivaltype then
begin
ntype := arrivalnode;
evar := makeNVar(eventtype,nil);
makeNewVar(evar); (* if active block deal with environment entry *)
end
else
ntype := departingnode;
end
else
begin
pp20L('Must be part of MOVE',20); pp10(' statement',10); errprnt;
end;
end
else if clause = errortype then
begin
oncond := newNode;
with oncond↑ do
begin
ntype := errornode;
getToken; (* skip over the "=" *)
eexpr := exprParse; (* get desired error bits *)
dimCheck(eexpr,nodim↑.dim);
end;
if not inMove then
begin (* no good *)
pp20L('Must be part of MOVE',20); pp10(' statement',10); errprnt;
end
else
begin (* point back to motion statement, not cmon *)
cursorStack[cursor-1].nd↑.errhandlerp := true;
st↑.conclusion↑.next↑.bparent := cursorStack[cursor-2].st;
end;
end
else
begin pp20L('Unknown ON condition',20); errprnt end
end
else if (ttype = reswdtype) and (rtype = optype) and (op = absop) then
begin (* is it |Force...| or |Torque...|? *)
getToken; (* see what next token is *)
backup := true;
if (ttype = reswdtype) and (rtype = clsetype) and
((clause = forcetype) or (clause = torquetype)) then
oncond := clauseParse(nil,true) (* yes - |Force/Torque...| cmon *)
else
begin (* no - expression cmon *)
exprCm := true;
t := copyToken; (* make a copy of token we just peeked at *)
next := t; (* fix things up so the peeked at token is next *)
ttype := reswdtype; (* and the "|" gets seen again by exprParse *)
rtype := optype;
op := absop;
if macrodepth = 0 then (* pretend we're a macro *)
begin
macrodepth := 1;
curmacstack[macrodepth] := nil;
macrostack[macrodepth] := nil;
end;
oncond := exprParse; (* get expression for cmon *)
relToken(t); (* done with peeked at token now *)
end
end
else
begin
backup := true;
oncond := exprParse; (* get the cmon condition *)
if getDtype(oncond) <> eventtype then exprCm := true;
end;
if oncond <> nil then
with oncond↑ do
if (ntype = forcenode) and not inMove then
begin
pp20L('Force sensing must b',20); pp20('e part of a MOVE sta',20);
pp10('tement ',6); errprnt;
relExpr(oncond);
oncond := nil;
end
else if exprCm or (ntype = durnode) or (ntype = forcenode) then
exprs := evalOrder(oncond,nil,true)
else if ntype = exprnode then (* subscripted event *)
exprs := evalOrder(arg2,nil,true)
else exprs := nil;
end;
if inMove then moveOrder(cursorStack[cursor-2].st);
end;
(* moveParse *)
procedure moveParse(st: statementp; bp: boolean);
var b,movep,jointp,operatep,centerp,openp,floatp: boolean; dest: nodep;
begin
with st↑ do
begin
movep := stype = movetype;
jointp := stype = jtmovetype;
operatep := stype = operatetype;
centerp := stype = centertype;
floatp := stype = floattype;
openp := (stype = opentype) or (stype = closetype);
cf := exprParse; (* what are we moving *)
if movep and (cf <> nil) then
if (cf↑.ntype = exprnode) and (cf↑.op = jointop) then
begin movep := false; jointp := true; stype := jtmovetype end;
if movep or centerp or floatp then
cf := checkArg(cf,frametype)
else cf := checkArg(cf,svaltype);
with cf↑ do (* make sure it's a variable *)
begin
if jointp and ((ntype <> exprnode) or (op <> jointop)) then
begin movep := true; jointp := false; stype := movetype end;
b := (ntype <> leafnode) or (ltype <> varitype);
if b then b := (ntype <> exprnode) or ((op <> arefop) and (op <> jointop));
if not b then (* ok so far, check some more *)
if centerp then
begin (* check for arms *)
if ntype <> leafnode then b := true
else b := (vari↑.level <> 0) or not (vari↑.offset in [0,4]);
(* offsets: 0=garm, 4=rarm *)
end
else if operatep then
begin (* check for driver *)
if ntype <> leafnode then b := true
else b := (vari↑.level <> 0) or (vari↑.offset <> 8);
(* offset: 8=driver *)
end
else if openp then
begin (* check for scalar devices *)
if ntype <> leafnode then b := true
else b := (vari↑.level <> 0) or not (vari↑.offset in [2,6,12]);
(* offsets: 2=ghand, 6=rhand, 12=vise *)
end;
end;
if b then
begin
pp20L(' Need a device varia',20); pp10('ble here ',8); errprnt;
bad := true; (* mark statement as bad *)
end
else
bad := false; (* statement is ok *)
getToken; (* see if there's a TO clause *)
if movep or jointp or openp then
begin (* deal with possible dest *)
dest := clauses;
if dest <> nil then
begin
with dest↑ do
if (ntype = ffnode) and pdef then dest := next;
if dest↑.ntype <> destnode then dest := nil
else relExpr(dest↑.loc);
end;
with curToken do
begin
if (ttype = reswdtype) and (rtype = filtype) and (filler = totype) then
begin (* get destination *)
if dest = nil then
begin (* make a new destination node *)
dest := newNode;
with dest↑ do
begin
ntype := destnode;
code := nil;
next := clauses; (* splice us into clause list *)
clauses := dest;
end;
end;
with dest↑ do
begin
if movep then loc := checkArg(exprParse,transtype)
else loc := checkArg(exprParse,svaltype);
if not jointp then dimCheck(loc,distancedim↑.dim)
else dimCheck(loc,angledim↑.dim);
getToken; (* see if anything else on line *)
end
end
else
if dest <> nil then (* delete old destination clause *)
begin
if clauses = dest then clauses := dest↑.next
else clauses↑.next := dest↑.next; (* system created ffnode *)
relNode(dest);
end;
end;
end;
backup := true;
with curToken do
if not (bp or endOfLine or ((ttype = delimtype) and (ch = ';'))) then
begin
pp20L('Sorry, can''t deal wi',20); pp20('th last part of line',20); errprnt;
(* *** maybe instead should call addstmnt here??? *** *)
end;
end;
moveOrder(st);
end;
(* mClauseParse *)
procedure mClauseParse(n: nodep);
var np,no,oldVClauses: nodep; strp: strngp; b,movep,jointp: boolean;
oldVcode: statementp; pttype: nodetypes;
begin (* dest, via, with *)
with cursorStack[cursor-1].st↑ do
begin
movep := stype = movetype;
jointp := stype = jtmovetype;
end;
with n↑ do
if ntype = destnode then
begin
relExpr(loc);
if movep then loc := checkArg(exprParse,transtype)
else loc := checkArg(exprParse,svaltype);
if jointp then dimCheck(loc,angledim↑.dim)
else dimCheck(loc,distancedim↑.dim);
end
else if (ntype = viaptnode) or (ntype = byptnode) then
begin (* ** maybe should check that this is a MOVE stmnt ?? ** *)
pttype := n↑.ntype; (* remember if it's a VIA or BY *)
np := n;
oldVClauses := nil;
oldVcode := nil;
while np <> nil do (* first free up old values *)
begin
with np↑ do
begin
relExpr(via);
if vclauses <> nil then oldVClauses := vclauses; (* remember WHERE's *)
if vcode <> nil then oldVcode := vcode; (* also remember old code *)
np := next;
end;
if np <> nil then
if (np↑.ntype <> pttype) or (not np↑.vlist) then np := nil;
end;
with curToken do
repeat
with n↑ do
begin
if jointp then via := checkArg(exprParse,svaltype)
else if ntype = viaptnode then via := checkArg(exprParse,transtype)
else if movep then
begin
via := exprParse;
if getdtype(via) <> vectype then via := checkArg(via,transtype);
end
else via := checkArg(exprParse,svaltype);
if jointp then dimCheck(via,angledim↑.dim)
else dimCheck(via,distancedim↑.dim);
vclauses := nil;
vcode := nil;
getToken;
end;
if (ttype = delimtype) and (ch = ',') then
begin (* need to add a new via point *)
if n↑.next = nil then b := true
else b := (n↑.next↑.ntype <> pttype) or (not n↑.next↑.vlist);
if b then
begin (* make up a new node *)
np := newNode;
with np↑ do
begin
ntype := pttype; (* VIA or BY point *)
next := n↑.next;
vlist := true;
end;
n↑.next := np;
n := np;
end
else n := n↑.next; (* just re-use next VIA/BY list node *)
b := false;
end
else b := true;
until b;
n↑.vclauses := oldVClauses; (* keep tabs on associated WHERE clauses *)
n↑.vcode := oldVcode; (* and also on any associated code *)
np := n↑.next;
while np <> nil do (* flush any extra VIA/BY list nodes *)
with np↑ do
if (ntype = pttype) and vlist then
begin no := np; np := next; relNode(no); n↑.next := np end
else np := nil;
backup := true;
end
else if ntype = commentnode then
begin
while str <> nil do (* release old comment string *)
begin strp := str↑.next; relStrng(str); str := strp end;
curChar := 1;
maxChar := maxChar + 9;
flushComments := false;
getToken; (* get the comment *)
flushComments := true;
length := curToken.len; (* don't even need to check it?!? *)
str := curToken.str;
end
else
begin (* a WITH clause *)
case ntype of (* release old expressions *)
deprnode,
apprnode: relExpr(loc);
durnode: relExpr(durval);
velocitynode,
sfacnode,
wobblenode,
swtnode: relExpr(clval);
ffnode: relExpr(ff);
forcenode: begin relExpr(fval); relExpr(fvec); relExpr(fframe); end;
stiffnode: begin relExpr(fv); relExpr(mv); relExpr(cocff); end;
others: begin end; (* nothing to do *)
end;
np := clauseParse(n,false);
end;
moveOrder(cursorStack[cursor-1].st);
end;
(* stopParse *)
procedure stopParse(st: statementp);
var d: datatypes; b: boolean; i: integer;
procedure complain;
begin (* no good *)
pp20L(' Need a device varia',20); pp10('ble here ',8); errprnt;
end;
begin (* stop & setbase statements *)
with st↑ do
begin
b := true;
clauses := nil;
cf := exprParse; (* what are we stopping? *)
if cf = nil then (* use default = cf of current motion (if any) *)
if stype = setbasetype then complain
else
begin
i := cursor;
while (i > 1) and b do
with cursorStack[i] do
if stmntp and (movetype <= st↑.stype) and (st↑.stype <= floattype) then
b := false else i := i - 1;
if b then
begin
pp20L(' Need to specify wha',20); pp10('t to Stop ',9); errprnt;
end
end
else
begin (* make sure it's a variable *)
d := getDtype(cf);
with cf↑ do
if ((ntype = leafnode) and (ltype = varitype)) or
((ntype = exprnode) and (op = arefop)) then (* a variable? *)
if d = frametype then b := false (* assume any frame var is ok *)
else if stype = setbasetype then b := true (* scalar devs no good for setbase *)
else if (d = svaltype) and (ntype = leafnode) then
if (vari↑.level = 0) and (* check for scalar devices *)
(vari↑.offset in [2,6,8,12]) then b := false;
(* offsets: 2=ghand, 6=rhand, 8=driver, 12=vise *)
if b then complain;
end
end;
end;
(* returnParse *)
procedure returnParse(st: statementp);
var n,np: nodep;
begin
relExpr(st↑.retval); (* flush the old expression *)
st↑.retval := exprParse; (* parse the modified expression *)
n := st↑.rproc; (* find def of procedure we're in *)
if n = nil then
begin (* yow - shouldn't allow a return here *)
pp20L(' Can''t have a return',20); pp5('here ',4); errprnt;
end
else if n↑.pname↑.vtype = nulltype then
begin (* procedure doesn't return a result *)
pp20L(' Procedure doesn''t r',20); pp20('eturn result ',12); errprnt;
end
else if st↑.retval <> nil then
begin
st↑.retval := checkArg(st↑.retval,n↑.pname↑.vtype);
np := nil;
dimCheck(st↑.retval,getdim(n,np));
relNode(np);
end
else
begin pp20L(' Need a value to ret',20); pp10('urn with ',8); errprnt end;
with st↑ do
if retval <> nil then exprs := evalOrder(retval,nil,true)
else exprs := nil;
end;
(* waitParse & wristParse *)
procedure waitParse(sp: statementp);
begin
with sp↑ do
begin
event := checkArg(exprParse,eventtype);
exprs := nil;
with event↑ do (* make sure it's a variable *)
if not (((ntype = leafnode) and (ltype = varitype)) or
((ntype = exprnode) and (op = arefop))) then
begin (* no good *)
pp20L(' Need an event varia',20); pp10('ble here ',8); errprnt;
relExpr(event);
event := nil;
end
else
if ntype <> leafnode then exprs := evalOrder(arg2,nil,true);
end;
end;
procedure wristParse(st: statementp);
var b: boolean; n: nodep;
procedure complain;
begin
st↑.bad := true; (* mark statement as bad *)
pp20L(' Need variable here ',19); errprnt;
end;
begin
with st↑ do
begin
bad := false; (* assume statement is ok *)
getDelim('(');
fvec := checkArg(exprParse,vectype);
dimCheck(fvec,forcedim↑.dim);
with fvec↑ do (* make sure it's a variable *)
if not (((ntype = exprnode) and (op = arefop)) or
((ntype = leafnode) and (ltype = varitype))) then complain;
getDelim(',');
tvec := checkArg(exprParse,vectype);
dimCheck(tvec,torquedim↑.dim);
with tvec↑ do (* make sure it's a variable *)
if not (((ntype = exprnode) and (op = arefop)) or
((ntype = leafnode) and (ltype = varitype))) then complain;
getDelim(')');
b := false;
arm := nil;
ff := nil;
csys := false; (* assume hand coords *)
repeat
getToken; (* look for ABOUT, IN or OF spec *)
with curToken do
if (ttype = reswdtype) and (rtype = filtype) and
((filler = abouttype) or (filler = intype) or (filler = oftype)) then
case filler of
abouttype: begin
ff := checkArg(exprParse,transtype);
dimCheck(ff,distancedim↑.dim);
end;
intype: csys := getcsys(false); (* get coord sys, hand = default *)
oftype: begin
arm := checkArg(exprParse,frametype);
with arm↑ do
if not (((ntype = leafnode) and (ltype = varitype)) or
((ntype = exprnode) and (op = arefop))) then
begin (* not a variable - no good *)
pp20L(' Need a device varia',20); pp10('ble here ',8); errprnt;
end;
end;
end
else begin backup := true; b := true end; (* all done *)
until b;
n := nil;
if arm <> nil then
with arm↑ do
if (ntype = exprnode) and (op = arefop) then
n := evalorder(arg2,n,true); (* deal with subscripts *)
if ff <> nil then
n := evalorder(ff,n,true); (* push wrist frame *)
with fvec↑ do
if (ntype = exprnode) and (op = arefop) then
n := evalorder(arg2,n,true); (* deal with subscripts *)
with tvec↑ do
if (ntype = exprnode) and (op = arefop) then
n := evalorder(arg2,n,true); (* deal with subscripts *)
exprs := n;
end
end;
(* armMagicParse *)
procedure armMagicParse(sp: statementp);
var n,lexpr: nodep; b: boolean;
begin
with sp↑ do
begin
cmdnum := checkArg(exprParse,svaltype);
getDelim(',');
dev := exprParse;
if dev = nil then b := true
else
with dev↑ do (* make sure it's a variable *)
begin
b := (ntype <> leafnode) or (ltype <> varitype);
if b then b := (ntype <> exprnode) or (op <> arefop);
end;
if b then
begin
pp20L(' Need a device varia',20); pp10('ble here ',8); errprnt;
bad := true; (* mark statement as bad *)
end
else
bad := false; (* statement is ok *)
getToken;
backup := true;
if (not endOfLine) or
(curToken.ttype <> delimtype) or (curToken.ch <> ';') then getDelim(',');
pnode↑.arg2 := nil;
getArgs(pnode); (* pretend we just saw a queryop *)
iargs := pnode↑.arg2; (* store away pointer to argument list *)
getToken;
backup := true;
if (not endOfLine) or
(curToken.ttype <> delimtype) or (curToken.ch <> ';') then getDelim(',');
pnode↑.arg2 := nil;
getArgs(pnode); (* do it all again for results list *)
oargs := pnode↑.arg2;
n := oargs;
b := false;
while (n <> nil) and not b do
begin (* make sure each entry in result list is a variable *)
with n↑.lval↑ do
begin
b := (ntype <> leafnode) or (ltype <> varitype);
if b then b := (ntype <> exprnode) or (op <> arefop);
end;
n := n↑.next;
end;
if b then
begin
pp20L(' Can only have varia',20); pp10('bles here ',9); errprnt;
bad := true; (* mark statement as bad *)
end;
if not bad then
begin (* set up exprs field *)
lexpr := evalOrder(cmdnum,nil,true);
if dev <> nil then (* evaluate device *)
if dev↑.ntype <> leafnode then
lexpr := evalOrder(dev↑.arg2,nil,true); (* push array subscripts *)
lexpr := evalOrder(iargs,lexpr,true); (* push input arguments *)
n := oargs;
while n <> nil do
with n↑ do
begin (* push any subscripts in result list *)
if lval↑.ntype = exprnode then lexpr := evalOrder(n↑.lval,lexpr,true);
n := next;
end;
exprs := lexpr;
end;
end;
end;
(* editStmnt: aux routines: echarDo, goEd, editExpr, downLine *)
procedure editStmnt;
var i,j,l,ocur,indent,e0,elen: integer;
n,nv: nodep; s,sp: statementp; ch,echar: ascii; strp: strngp;
b,again: boolean;
procedure echarDo;
begin
if echar >= 'P' then cursorLine := cursorLine - 1 (* U or P *)
else cursorLine := cursorLine + 1; (* cr or N *)
again := not odd(ord(echar)); (* keep going if N or P *)
end;
procedure goEd;
begin
with lines[l]↑ do (* go edit it *)
echar := exprEditor(l-firstDline+1,start,length,e0,elen,0);
end;
function editExpr(n: nodep): nodep;
begin
elen := getExprLength(n);
relExpr(n); (* flush the old expression *)
goEd;
n := exprParse; (* parse the modified expression *)
echarDo;
editExpr := n;
end;
procedure downLine;
begin
cursorLine := cursorLine + 1;
setCursor := true;
adjustDisplay;
displayLines(lineNum); (* shift display if necessary *)
again := true;
ocur := 0;
end;
(* editStmnt: main body *)
begin
setExpr := true;
repeat
newDeclarations := nil;
l := cursorLine - topDline + 1; (* offset into line array *)
ocur := cursorLine;
again := false;
with cursorStack[cursor] do
begin
if stmntp then s := st else n := nd;
indent := ind + 1;
end;
if cursorStack[cursor].stmntp then
if fieldNum = 0 then
begin (* modify statement label *)
elen := lines[l]↑.length;
goEd;
labelParse;
echarDo;
end
else
with s↑ do
case stype of
(* requiretype, definetype, dimdeftype *)
blocktype,
coblocktype,
endtype,
coendtype: begin
echar := idGet(s,indent,l);
echarDo;
end;
declaretype: begin
echar := varParse(s,indent,l);
echarDo;
reFormatStmnt(s,indent,ocur); (* may have changed nlines *)
ocur := 0;
end;
calltype,
assigntype: begin
e0 := indent;
elen := getExprLength(what);
if stype = assigntype then
elen := elen + getExprLength(aval) + 4;
relExpr(what);
relExpr(aval);
goEd;
assignParse(s,nil);
echarDo;
end;
returntype: begin
e0 := indent + 7;
if retval = nil then begin e0 := e0 - 1; elen := 0 end
else elen := getExprLength(retval);
goEd;
returnParse(s);
echarDo;
end;
iftype: begin
if fieldNum = 1 then
begin (* edit <cond> *)
e0 := indent + 3;
icond := checkArg(editExpr(icond),svaltype);
exprs := evalOrder(icond,nil,true);
end
else downLine; (* just move on to ELSE statement *)
end;
whiletype: begin (* edit <cond> *)
e0 := indent + 6;
cond := checkArg(editExpr(cond),svaltype);
exprs := evalOrder(cond,nil,true);
end;
untiltype: begin
if fieldNum = 2 then
begin (* edit <cond> *)
e0 := indent + 6;
cond := checkArg(editExpr(cond),svaltype);
exprs := evalOrder(cond,nil,true);
end
else downLine; (* just move on to body *)
end;
fortype: begin
e0 := indent + 4;
with lines[l]↑ do
begin (* go edit it *)
i := length - 1;
while listing[start+i] <> 'd' do i := i - 1;
elen := i - e0;
end;
goEd;
relExpr(forvar);
relExpr(initial);
relExpr(step);
relExpr(final);
forParse(s);
echarDo;
end;
casetype: begin
if fieldNum = 1 then
begin (* edit <index> *)
e0 := indent + 5;
index := checkArg(editExpr(index),svaltype);
exprs := evalOrder(index,nil,true);
end
else downLine; (* just move on to first case *)
end;
affixtype: begin
if fieldnum = 1 then
begin
e0 := indent + 6;
elen := getExprLength(frame1) + getExprLength(frame2) + 4;
relExpr(frame1);
relExpr(frame2);
if byvar <> nil then elen := elen + 4 + getExprLength(byvar);
relExpr(byvar);
if rigid then elen := elen + 8 else elen := elen + 11;
if byvar <> nil then elen := elen + 4 + getExprLength(byvar);
relExpr(byvar);
end
else begin e0 := indent + 5; elen := -4 end;
if (fieldnum = 5) or (nlines = 1) then
begin
if atexp <> nil then elen := elen + 4 + getExprLength(atexp);
relExpr(atexp);
end;
goEd;
affixParse(s);
echarDo;
reFormatStmnt(s,indent,ocur); (* may have changed nlines *)
ocur := 0;
end;
unfixtype: begin
e0 := indent + 6;
elen := getExprLength(frame1) + getExprLength(frame2) + 6;
relExpr(frame1);
relExpr(frame2);
goEd;
unfixParse(s);
echarDo;
end;
printtype,
prompttype,
aborttype,
saytype: begin
if (fieldNum = 1) and (stype = prompttype) then e0 := indent + 7
else if stype = saytype then e0 := indent + 4
else e0 := indent + 6;
echar := plistParse(s,e0,indent,l,ocur);
echarDo;
ocur := 0;
end;
pausetype: begin
e0 := indent + 6;
ptime := checkArg(editExpr(ptime),svaltype);
dimCheck(ptime,timedim↑.dim); (* right dimension? *)
exprs := evalOrder(ptime,nil,true);
end;
movetype,
jtmovetype,
operatetype,
opentype,
closetype,
centertype,
floattype,
setbasetype,
stoptype: begin
if (stype = operatetype) or (stype = setbasetype) then e0 := 8
else if stype = centertype then e0 := 7
else if (stype = closetype) or (stype = floattype) then e0 := 6
else e0 := 5;
e0 := e0 + indent;
with lines[l]↑ do
begin (* go edit it *)
elen := length - e0 + 1;
if listing[start+length-1] = ';' then elen := elen - 1;
end;
goEd;
relExpr(cf);
if (stype = stoptype) or (stype = setbasetype) then stopParse(s)
else moveParse(s,false);
echarDo;
end;
signaltype,
waittype: begin
if stype = signaltype then e0 := indent + 7
else e0 := indent + 5;
event := checkArg(editExpr(event),eventtype);
exprs := nil;
with event↑ do (* make sure it's a variable *)
if not (((ntype = leafnode) and (ltype = varitype)) or
((ntype = exprnode) and (op = arefop))) then
begin (* no good *)
pp20L(' Need an event varia',20); pp10('ble here ',8); errprnt;
relExpr(event);
event := nil;
end
else
if ntype <> leafnode then exprs := evalOrder(arg2,nil,true);
end;
cmtype: begin
e0 := indent;
with lines[l]↑ do
begin (* go edit it *)
i := length - 1;
while listing[start+i] <> 'd' do i := i - 1;
elen := i - e0;
end;
goEd;
cmonParse(s,true);
echarDo;
end;
enabletype,
disabletype: begin
if stype = enabletype then e0 := indent + 7
else e0 := indent + 8;
if cmonlab = nil then elen := 0
else elen := cmonlab↑.name↑.length;
goEd;
enableParse(s);
echarDo;
end;
commenttype: begin (* *** only good for single line comments now *** *)
if nlines > 1 then
begin pp20L('Sorry, can''t edit mu',20);
pp20('lti-line comments ye',20); ppChar('t'); ppLine end
else
begin
ch := str↑.ch[1];
if (ch = 'C') or (ch = chr(smallC)) then
begin (* comment ... ; *)
e0 := indent + 8;
elen := len - 9;
end
else
begin (* "{" "(*" or "/*" *)
if ch = chr(lbrace) then e0 := indent + 1
else e0 := indent + 2;
elen := len + indent - e0 - 2;
j := (len-1) MOD 10 + 1; (* Index of last char in comment *)
strp := str;
for i := 1 to (len-1) DIV 10 do strp := strp↑.next;
if strp↑.ch[j] = chr(rbrace) then elen := elen + 1;
end;
while str <> nil do (* release old comment string *)
begin strp := str↑.next; relStrng(str); str := strp end;
goEd; (* edit new one *)
curChar := indent;
maxChar := indent + elen + 9;
flushComments := false;
getToken; (* get the comment *)
flushComments := true;
len := curToken.len; (* don't even need to check it?!? *)
str := curToken.str;
echarDo;
end;
end;
wristtype: begin
e0 := indent + 5;
relExpr(fvec);
relExpr(tvec);
relExpr(ff);
relExpr(arm);
with lines[l]↑ do
begin (* go edit it *)
elen := length - e0 + 1;
if listing[start+length-1] = ';' then elen := elen - 1;
end;
goEd;
wristParse(s);
echarDo;
end;
retrytype: downLine; (* nothing to edit here *)
armmagictype: begin
e0 := indent + 10;
with lines[l]↑ do
begin (* go edit it *)
elen := length - e0 + 1;
if listing[start+length-1] = ';' then elen := elen - 1;
end;
goEd;
relExpr(cmdnum);
relExpr(dev);
relExpr(iargs);
relExpr(oargs);
armmagicParse(s);
echarDo;
end;
others: begin
pp20L(' Don''t know how to e',20); pp20('dit this type yet. ',18);
ppLine;
ocur := 0;
end;
end
else
begin
with n↑ do
if ntype = procdefnode then
begin
(* *** check that procedure is not currently active ??? *** *)
echar := procParse(n,indent,l);
end
else if ntype = clistnode then
begin (* edit the label *)
e0 := indent + 1;
with lines[l]↑ do
begin (* go edit it *)
elen := length - e0 + 1;
end;
goEd;
clabelParse(n);
end
else if ((ntype = viaptnode) or (ntype = byptnode)) and
(fieldNum > 1) then
begin (* WHERE clause in VIA/BY *)
e0 := 8 + indent;
with lines[l]↑ do
begin (* go edit it *)
elen := length - e0 + 1;
if listing[start+length-1] = ';' then elen := elen - 1;
end;
goEd;
nv := n;
b := true;
while b and (nv↑.next <> nil) do (* find last VIA/BY in list *)
with nv↑.next↑ do
if (ntype = nv↑.ntype) and vlist then nv := nv↑.next else b := false;
nv := nv↑.vclauses;
for i := 3 to fieldNum do nv := nv↑.next; (* find WHERE clause *)
mClauseParse(nv);
end
else if (cursorStack[cursor].cline < cursorLine) and
(fieldNum = 1) then echar := chr(cr) (* just skip past THEN *)
else
begin (* a motion clause *)
case ntype of
destnode,
byptnode: e0 := 3;
viaptnode: e0 := 4;
cwnode: e0 := 0;
commentnode: e0 := 0; (* *** should be a little smarter here *** *)
others: e0 := 5; (* a WITH clause *)
end;
e0 := e0 + indent;
with lines[l]↑ do
begin (* go edit it *)
elen := length - e0 + 1;
if listing[start+length-1] = ';' then elen := elen - 1;
end;
goEd;
mClauseParse(n);
end;
echarDo;
end;
l := addNewDeclarations;
if ocur > 0 then
begin (* unless told otherwise... *)
ocur := ocur + l;
firstLine := ocur;
lastLine := ocur;
l := ocur - topDline + 1; (* offset into line array *)
relLine(lines[l]); (* flush old line *)
lines[l] := nil;
curLine := 0;
putStmnt(dProg,0,99); (* write & display new line *)
end;
if (ocur <> cursorLine) or (newDeclarations <> nil) then
begin (* make sure new line is on screen *)
setCursor := true;
adjustDisplay;
displayLines(lineNum); (* shift display if necessary *)
end;
until not again;
setExpr := false;
end;
(* addStmnt: aux routines: getEmptyStmnt,flushSemi,descend,elseTest,restoreCursor,setUpNewStmnt,viaOk *)
procedure addStmnt(firstTime: boolean);
var i,j,l,indent,e0,elen,ocur,lcur: integer; nextLine: cursorp;
n,np,viaCl: nodep; s,sp: statementp; echar: ascii; slabel: varidefp;
b,emptyp,stOk,clOk,nogood,again,labp,flushp: boolean;
function getEmptyStmnt: statementp;
var st: statementp;
begin
st := newStatement;
with st↑ do
begin
stype := emptytype;
last := sp;
bparent := sp; (* so we can also use this for END's & COEND's *)
blkid := nil;
end;
appendEnd(sp,st); (* append an end statement to it *)
st↑.next↑.last := sp;
getEmptyStmnt := st;
end;
procedure flushSemi;
var i,j,l: integer;
begin
l := cursorLine - topDline;
if slabel <> nil then l := l - 1;
if l > 0 then
begin (* if needed flush the old ";" from previous line *)
with lines[l]↑ do (* fix up old line *)
begin
j := start;
i := start + length - 1;
end;
while (listing[i] = chr(0)) or (listing[i] = ' ') do i := i - 1;
if listing[i] = ';' then
begin (* flush the old semi-colon *)
listing[i] := ' ';
l := l - firstDline + 1;
if l > 0 then (* see if we need to update screen *)
outChar(l,i-j+1,' ',false);
end;
end;
end;
procedure descend(st: statementp);
var sp: statementp;
begin
sp := nil;
with st↑ do
case stype of
fortype: sp := fbody;
whiletype: sp := body;
iftype: if els <> nil then sp := els else sp := thn;
cmtype: sp := conclusion;
others: begin end; (* nothing to do *)
end;
curLine := curline + 1; (* better than nothing(?) *)
if sp <> nil then
begin pushStmnt(sp,0); descend(sp) end; (* don't worry about cline *)
end;
function elseTest: boolean;
var j,l: integer; b: boolean; n: nodep;
begin
b := not emptyp; (* if pointing at empty stmnt then no ELSE possible *)
if b then
begin
l := cursorLine;
if sParse and (cursor <= sCursor) then
begin
cursor := sCursor;
curLine := 0;
descend(cursorStack[sCursor].st);
end
else lastStmnt(1,true); (* back up to previous statement *)
cursorLine := l;
with cursorStack[cursor], st↑ do
if (movetype <= stype) and (stype <= floattype) and (clauses <> nil) then
begin
n := clauses;
while n↑.next <> nil do n := n↑.next; (* find last clause *)
if n↑.ntype = cmonnode then
begin
curLine := cline;
pushNode(n); (* don't worry that .cline fields will be wrong *)
pushStmnt(n↑.cmon,2);
descend(n↑.cmon);
end;
end;
b := true;
i := cursor;
if sParse then j := sCursor else j := 1;
while (i >= j) and b do (* look for an IF with no ELSE *)
begin
with cursorStack[i] do
if stmntp then
if l < cline + st↑.nlines then i := 0 (* inside stmnt *)
else if st↑.stype = iftype then b := st↑.els <> nil;
if b then i := i - 1 else cursor := i;
end;
end;
elseTest := b;
end;
procedure restoreCursor;
begin
setCursor := true;
curLine := 0;
firstLine := 0;
lastLine := -1;
if not sParse then putStmnt(dprog,0,99) (* write & display new line *)
else
begin
cursor := sCursor - 1;
putStmnt(cursorStack[sCursor].st,0,99);
if cursor < sCursor then cursor := sCursor
end;
setCursor := false;
with cursorStack[cursor] do (* don't point at a proc def node *)
if (not stmntp) and (nd↑.ntype = procdefnode) then cursor := cursor - 1;
end;
procedure setUpNewStmnt;
var b: boolean;
begin
setUp := true;
setCursor := false;
curLine := 1;
putStmnt(sp,nextLine.ind,99); (* see how long we are *)
if sp↑.stype = declaretype then
b := sp↑.variables↑.tbits <> 2 (* don't advance cursor for procedure *)
else b := true;
if b then cursorline := cursorline + sp↑.nlines - 1;
setUp := false;
end;
procedure viaOk(i: integer);
var n: nodep;
begin
if clOk then
with cursorStack[cursor-i].st↑ do
if (stype = movetype) or (stype = jtmovetype) then
begin
n := clauses;
if i = 1 then
begin
if n <> nextLine.nd then
while n↑.next <> nextLine.nd do n := n↑.next;
end
else
if n <> nil then
while n↑.next <> nil do n := n↑.next;
if n <> nil then
if (n↑.ntype = viaptnode) or (n↑.ntype = byptnode) then viaCl := n;
end;
end;
(* addStmnt: aux routines: addNewSt,addNode,addNewEnv,addCmon & addDeclSt *)
procedure addNewSt(sty: stmntypes);
var no,np: nodep;
begin
if stOk then
begin
if emptyp then sp := nextLine.st
else
begin
sp := newStatement;
if nextLine.stmntp then (* figure how to add statement *)
begin
sp↑.last := nextLine.st↑.last;
sp↑.next := nextLine.st;
if cursorStack[cursor-1].stmntp then
case cursorStack[cursor-1].st↑.stype of
blocktype: with cursorStack[cursor] do (* add us to block *)
begin
sp↑.next := st;
st↑.last := sp;
with sp↑.last↑ do (* check for start of block *)
if next = st then next := sp else bcode := sp;
st := sp; (* have cursor point to us *)
end;
coblocktype:begin
np := newNode;
with cursorStack[cursor-1].st↑ do
begin
no := threads;
if no = nil then threads := np
else
begin
while no↑.next <> nil do no := no↑.next;
no↑.next := np;
end;
nthreads := nthreads + 1;
end;
with np↑ do
begin
ntype := colistnode;
prev := no;
next := nil;
cstmnt := sp;
end;
cursor := cursor - 1;
curLine := cursorLine - 1;
if slabel <> nil then curLine := curLine - 1;
pushNode(np);
pushStmnt(sp,nextLine.ind+1);
end;
casetype: begin
(* *** later *** *)
end;
end
else
begin
np := newNode;
no := cursorStack[cursor-1].nd;
if no↑.ntype = colistnode then
with np↑ do
begin (* add us to coblock *)
ntype := colistnode;
cstmnt := sp;
next := no;
prev := no↑.prev;
no↑.prev := np;
if prev = nil then sp↑.last↑.threads := np else prev↑.next := np;
sp↑.last↑.nthreads := sp↑.last↑.nthreads + 1;
end
else
begin (* add us to case list *)
(* *** later *** *)
end;
cursorStack[cursor-1].nd := np; (* update cursor position *)
cursorStack[cursor].st := sp;
end
end
else
with cursorStack[cursor-1] do
begin (* add us to case list *)
(* *** later for this case *** *)
end
end;
with sp↑ do
begin
stlab := slabel;
stype := sty;
exprs := nil;
if slabel <> nil then
begin
slabel↑.s := sp;
nlines := 2;
end;
end;
end
else
begin
pp20L(' Can''t have a statem',20); pp10('ent here ',8); errprnt;
sp := nil;
nogood := true;
flushp := true;
end;
end;
function addNode: nodep;
var n,np,no: nodep; i,l: integer;
begin
np := newNode;
np↑.next := nil;
if nextLine.stmntp and (cursorStack[cursor-1].stmntp or
(sParse and (cursor <= sCursor))) then
begin (* need to append a new clause *)
l := cursorLine; (* since calling lastStmnt will change it *)
i := cursor;
if sParse and (cursor <= sCursor) then
begin
cursor := sCursor;
descend(cursorStack[sCursor].st);
end
else lastStmnt(1,true); (* backup to motion stmnt *)
cursorLine := l;
for l := i to cursor do (* update part of cursor stack that was just *)
with cursorStack[l] do (* added to the stack by lastStmnt *)
if stmntp then st↑.nlines := st↑.nlines + 1;
with cursorStack[cursor].st↑ do
begin
n := clauses;
if n = nil then clauses := np
else (* find last clause *)
begin while n↑.next <> nil do n := n↑.next; n↑.next := np end;
end;
if not fparse then flushSemi;
curLine := cursorLine - 1;
if slabel <> nil then curline := curline - 1;
pushNode(np);
cursorStack[cursor].ind := cursorStack[cursor-1].ind + 2;
end
else
begin (* add us to clause list *)
if nextLine.stmntp then cursor := cursor - 1; (* pop up to node *)
with cursorStack[cursor] do
begin (* fix up cursorStack *)
np↑.next := nd;
no := nd;
nd := np;
end;
with cursorStack[cursor-1].st↑ do
begin (* find where to insert new clause & do it *)
if clauses = no then clauses := np
else
begin
n := clauses;
while (n↑.next <> nil) and (n↑.next <> no) do n := n↑.next;
n↑.next := np; (* either we found it or we're at the end *)
end;
end;
end;
addNode := np;
end;
procedure addNewEnv;
var i: integer; envhdr,ep: envheaderp;
begin
i := cursor;
while cursorStack[i].st <> curBlock do i := i - 1;
i := cursorStack[i].cline;
if (curBlock↑.variables = nil) and
(i < cursorLine) and (cursorLine < i + curBlock↑.nlines) then
begin (* need to make a new environment header for pdb *)
envhdr := newEheader;
with envhdr↑ do
begin
parent := eCurInt↑.env;
ep := nil;
while curBlock↑.level < getELev(parent) do
begin (* find our level in environment list *)
ep := parent;
parent := parent↑.parent;
end;
if ep <> nil then ep↑.parent := envhdr; (* splice us into list *)
block := curBlock;
procp := false;
for i := 0 to 4 do env[i] := nil;
varcnt := 0;
end;
end;
end;
procedure addCmon(defer: boolean);
var n: nodep; v: varidefp;
begin
if not clOk then addNewSt(cmtype)
else
begin
sp := newStatement;
with sp↑ do
begin
stype := cmtype;
stlab := slabel;
exprs := nil;
if slabel <> nil then
begin
slabel↑.s := sp;
nlines := 2;
end;
end;
n := addNode;
with n↑ do
begin
ntype := cmonnode;
cmon := sp;
end;
curLine := cursorLine - 1;
if slabel <> nil then curline := curline - 1;
pushStmnt(sp,0);
end;
v := makeNVar(cmontype,nil);
v↑.s := sp;
with sp↑ do
begin
deferCm := defer;
oncond := nil;
conclusion := getEmptyStmnt;
cdef := v;
nlines := nlines + 1;
end;
cmonParse(sp,false);
getDo;
addNewEnv; (* make up a new environment if needed *)
makeNewVar(v); (* if active block make env entry for var *)
end;
procedure addDeclSt;
var b: boolean; v,vp,vo: varidefp; i: integer;
begin
with cursorStack[cursor-1] do
b := stmntp and (st↑.stype = blocktype) and stOk; (* check in a block *)
if b then
begin (* add a new declaration statement *)
addNewSt(declaretype);
addNewEnv;
v := nil;
v := getDeclarations(false,curBlock↑.level,v,i,dumDup);
sp↑.numvars := i; (* remember # of variables *)
if v = nil then
begin
nogood := true;
sp↑.next↑.last := sp↑.last; (* splice out bad decl stmnt *)
if sp↑.last↑.next = sp then sp↑.last↑.next := sp↑.next
else sp↑.last↑.bcode := sp↑.next;
relStatement(sp);
sp := nil;
end
else
begin
vo := nil;
while v <> nil do
begin
vp := makeNVar(v↑.vtype,v↑.name);
if vo = nil then sp↑.variables := vp else vo↑.dnext := vp;
vo := vp;
with vp↑ do
begin (* copy relevant fields *)
dtype := v↑.dtype;
tbits := v↑.tbits;
if odd(tbits) then a := v↑.a (* copy array bounds *)
else if tbits = 2 then
begin (* need to do special stuff for procedure??? *)
p := v↑.p; (* copy proc def *)
p↑.pname := vp;
if p↑.body↑.stype = blocktype then cursorLine := cursorLine + 1;
end;
end;
makeNewVar(vp); (* if active block make env entry for var *)
vp := v↑.dnext;
relVaridef(v); (* all done with the duplicate varidef now *)
v := vp;
end;
if cursorstack[2].st <> curBlock then
begin
reParse(curBlock);
lcur := 0; (* since reParse will update display *)
end
else setUpNewStmnt;
end;
end
else
begin
pp20L(' Can''t have a declar',20); pp10('ation here',10); errprnt;
nogood := true;
flushp := true;
end
end;
(* addStmnt: main body *)
begin
setExpr := true;
repeat
echar := chr(CR);
repeat
if not sParse then newDeclarations := nil;
sp := nil;
nogood := false;
flushp := false;
labp := false;
ocur := cursorLine;
lcur := ocur;
with cursorStack[cursor] do (* don't point at a proc def node *)
if (not stmntp) and (nd↑.ntype = procdefnode) then cursor := cursor - 1;
with cursorStack[cursor] do
begin (* figure out where we are *)
nextLine.ind := ind; (* copy current cursor info *)
nextLine.stmntp := stmntp;
nextLine.st := st; (* also copies nd pointer *)
emptyp := false; (* assume we need to add a new line *)
if stmntp then emptyp := st↑.stype = emptytype; (* unless we can use current one *)
end;
viaCl := nil;
if emptyp then
begin
if not fParse then
begin
l := cursorLine - topDline + 1; (* offset into line array *)
relLine(lines[l]); (* release old empty line *)
lines[l] := nil;
clearLine(l-firstDline+1); (* clear line *)
end;
clOk := false; (* only accept a statement *)
stOk := true;
end
else
begin (* need to insert a new line *)
insertLines(cursorLine,1,1);
if not nextLine.stmntp then
begin (* if it isn't a statement neither are we *)
stOk := nextLine.nd↑.ntype = clistnode; (* unless it's a case label *)
clOk := not stOk;
with nextLine.nd↑ do
if ((ntype = viaptnode) or (ntype = byptnode)) and (fieldNum > 1) then
viaCl := nextLine.nd
else viaOk(1);
end
else if sParse and (cursor <= sCursor) then
begin (* if last is a motion statement then clause is ok *)
descend(cursorStack[sCursor].st);
with cursorStack[cursor].st↑ do
clOk := (movetype <= stype) and (stype <= floattype);
stOk := false; (* statements are no good here *)
viaOk(0);
cursor := sCursor; (* pop back *)
end
else
begin (* see if it's in a block, coblock or case *)
with cursorStack[cursor-1] do
if stmntp then
stOk := (st↑.stype = blocktype) or (st↑.stype = coblocktype) or
(st↑.stype = casetype)
else stOk := (nd↑.ntype = clistnode) or (nd↑.ntype = colistnode);
l := cursorLine;
lastStmnt(1,true); (* see if last statement can have clauses *)
with cursorStack[cursor].st↑ do
clOk := (movetype <= stype) and (stype <= floattype);
viaOk(0);
cursorLine := l;
restoreCursor;
end
end;
if viaCl <> nil then
begin
b := true;
while b and (viaCl↑.next <> nil) do (* find correct VIA/BY node *)
with viaCl↑.next↑ do
if (ntype = viaCl↑.ntype) and vlist then viaCl := viaCl↑.next
else b := false;
end;
if firstTime then
begin (* get insertion *)
elen := 1;
listing[1] := ' ';
echar := exprEditor(cursorLine-topDline-firstDline+2,1,1,1,elen,0);
end;
slabel := nil;
with curToken do
begin
if not fParse then flushcomments := false (* comments are ok here *)
else if clOk then flushcomments := true (* so don't loose any clauses *)
else if stOk then
begin
flushcomments := true; (* assume comments are no good here *)
with cursorStack[cursor-1] do
if stmntp then
if st↑.stype = blocktype then (* comments have to be in block *)
if nextLine.stmntp then
begin
flushcomments := not elseTest;
restoreCursor;
end;
end;
(* figure out what we're inserting: statement, label, clause *)
repeat getToken until (ttype <> delimtype) or (ch <> ';'); (* skip semi's *)
flushcomments := true; (* don't allow comments anywhere else *)
if ttype = labeldeftype then
begin (* a label *)
slabel := lab; (* copy pointer to label *)
cursorLine := cursorLine + 1;
getToken; (* move on to start of new statement? *)
if not endOfLine then lcur := lcur + 1;
if not (stOk or nextLine.stmntp or (clOk and (ttype = reswdtype) and
(((rtype = filtype) and (filler = defertype)) or
((rtype = stmnttype) and (stmnt = cmtype))) )) then
begin
pp20L(' Can''t have a label ',20); pp5('here ',4); errprnt;
if endOfLine then nogood := true; (* maybe there's something else? *)
end
end
else if (ttype = delimtype) and (ch = '[') then
begin (* a case label *)
(* *** worry about this case later *** *)
end
else if (ttype = reswdtype) and (rtype = filtype) then
if filler = elsetype then
begin (* must be after an if-then with no else, or in a labelled case stmnt *)
(* *** code to handle labelled case case *** *)
j := cursor;
b := elseTest;
if not b then
begin (* add an empty statement *)
if not fparse then flushSemi;
for i := j to cursor do (* update part of cursor stack that was *)
with cursorStack[i] do (* just added to the stack by elseTest *)
if stmntp then st↑.nlines := st↑.nlines + 1;
sp := cursorStack[cursor].st;
sp↑.els := getEmptyStmnt;
sp := sp↑.els;
curline := cursorLine; (* & update cursor stack *)
pushStmnt(sp,2);
nextLine.st := sp;
nextLine.stmntp := true;
sp := nil;
lcur := lcur + 1;
cursorLine := cursorLine + 1;
insertLines(cursorLine,1,1);
emptyp := true;
stOk := true;
clOk := false;
end;
labp := not b;
if b then
begin
pp20L(' Can''t have an "ELSE',20); pp10('" here ',6); errprnt;
nogood := true;
end
else
begin
getToken;
if endOfLine then cursorLine := cursorLine - 1;
end
end;
if (ttype = reswdtype) and (rtype = stmnttype) then
begin
if stmnt = cmtype then
begin (* cmons are special *)
addCmon(false);
end
else if (stmnt = endtype) or (stmnt = coendtype) then
begin (* these are special too *)
if nextline.stmntp and (nextline.st↑.stype = stmnt) then
begin (* move to previously defined stmnt *)
i := ord(idGet(nextLine.st,0,0)); (* & get any block id *)
deleteLines(ocur,1,1); (* flush the extra line *)
if not fparse then
begin
l := cursorLine - topDline + 1; (* offset into line array *)
relLine(lines[l]); (* release old line *)
lines[l] := nil;
end
else if cursor = 3 then endOfLine := true;
end
else
begin
pp20L('Can''t have an END/CO',20); pp10('END here ',8); errprnt;
flushp := true;
nogood := true;
end;
end
else if (stmnt = definetype) or (stmnt = requiretype) then
begin
pp20L('Can''t handle DEFINE ',20); pp20('or REQUIRE yet... ',17);
errprnt;
flushp := true;
nogood := true;
end
else
begin
addNewSt(stmnt);
if stOk then
with sp↑ do
case stmnt of
blocktype: begin
nlines := nlines + 1;
bparent := next; (* save next pointer *)
appendEnd(sp,sp);
bcode := next;
next := bparent;
bparent := curBlock;
with cursorStack[cursor-1] do
if (not stmntp) and (nd↑.ntype = procdefnode) then
level := nd↑.level + 1
else level := curBlock↑.level + 1;
numvars := 0;
variables := nil;
blkid := getBlkId;
curBlock := sp;
end;
coblocktype: begin
nlines := nlines + 2;
cblkid := getBlkId;
nthreads := 1;
threads := newNode;
with threads↑ do
begin
ntype := colistnode;
prev := nil;
next := nil;
cstmnt := getEmptyStmnt;
cstmnt↑.next↑.stype := coendtype;
end;
end;
iftype: begin
icond := checkArg(exprParse,svaltype);
exprs := evalOrder(icond,nil,true);
els := nil;
thn := getEmptyStmnt;
nlines := nlines + 1;
getToken;
if not endOfLine then
if (ttype <> reswdtype) or (rtype <> filtype) or
(filler <> thentype) then
begin
pp20L(' Need a "THEN" here ',19); errprnt;
backUp := true
end;
end;
fortype,
whiletype: begin
nlines := nlines + 1;
if stype = fortype then
begin
fbody := getEmptyStmnt;
forParse(sp);
end
else
begin
body := getEmptyStmnt;
cond := checkArg(exprParse,svaltype);
exprs := evalOrder(cond,nil,true);
end;
getDo;
end;
casetype: begin (* caseParse(sp); *) end;
returntype: begin
i := cursor;
n := nil;
repeat (* find def of procedure we're in, if any *)
with cursorStack[i] do
if stmntp then
if (st↑.stype = coblocktype) or (st↑.stype = cmtype) then
i := 0
else i := i - 1
else if nd↑.ntype = procdefnode then n := nd else i := i - 1;
until (i <= 2) or (n <> nil);
sp↑.rproc := n;
sp↑.retval := nil;
returnParse(sp);
end;
pausetype: begin
ptime := checkArg(exprParse,svaltype);
dimCheck(ptime,timedim↑.dim); (* right dimension? *)
exprs := evalOrder(ptime,nil,true);
end;
printtype,
prompttype,
aborttype,
saytype: begin
pnode↑.arg2 := nil;
getArgs(pnode); (* pretend we just saw a queryop *)
plist := pnode↑.arg2; (* store away pointer to print list *)
if plist <> nil then
begin
exprs := evalOrder(plist,nil,false);
setUpNewStmnt;
end;
debugLev := 0; (* for abort *)
end;
affixtype: begin
fieldNum := 1;
affixParse(sp);
setUpNewStmnt; (* check if it'll take two lines to print *)
end;
unfixtype: begin
unfixParse(sp);
end;
signaltype,
waittype: waitParse(sp);
movetype,
opentype,
closetype,
centertype,
floattype,
operatetype: begin
clauses := nil;
moveParse(sp,true);
end;
setbasetype,
stoptype: begin
stopParse(sp);
end;
retrytype: begin
(* *** need to check in the body of an error handler *** *)
(* *** also need to set .olevel *** *)
end;
enabletype,
disabletype: begin
enableParse(sp);
end;
wristtype: begin
wristParse(sp);
end;
armmagictype: begin
armmagicParse(sp);
end;
assigntype: begin (* shouldn't get here *)
backup := true;
assignParse(sp,nil);
end;
(* *** for now we're ignoring: requiretype, definetype & dimdeftype *** *)
end
end
end
else if (ttype = reswdtype) and (rtype = filtype) then
begin
if (filler = untltype) and (fieldNum = 2) and
nextLine.stmntp and (nextLine.st↑.stype = untiltype) then
with nextLine.st↑ do
begin (* this is special *)
cond := checkArg(exprParse,svaltype);
exprs := evalOrder(cond,nil,true);
if not emptyp then
deleteLines(ocur,1,1); (* flush the extra line *)
if not fParse then
begin
l := cursorLine - topDline + 1; (* offset into line array *)
relLine(lines[l]); (* release old line *)
lines[l] := nil;
end;
end
else if (filler = dotype) or (filler = untltype) then
begin
addNewSt(untiltype);
if stOk then
with sp↑ do
begin
if filler = untltype then
begin
cond := checkArg(exprParse,svaltype);
exprs := evalOrder(cond,nil,true);
cursorLine := cursorLine + 2;
end
else cond := nil;
nlines := nlines + 2;
body := getEmptyStmnt;
end
end
else if (filler = totype) or (filler = viatype) or (filler = bytype) or
(filler = withtype) then
begin
if clOk then
begin (* add a new motion clause *)
np := addNode;
with np↑ do
if filler = totype then
begin ntype := destnode; loc := nil; code := nil end
else if (filler = viatype) or (filler = bytype) then
begin
if filler = viatype then ntype := viaptnode else ntype := byptnode;
vlist := false; via := nil; vclauses := nil; vcode := nil
end
else ntype := nullingnode; (* random choice *)
mClauseParse(np);
with cursorStack[cursor-1] do
if (filler = totype) and (st↑.clauses = np) then
begin (* clause should go on previous line *)
l := cline - topDline + 1;
if (l > 0) and not fParse then (* if any *)
begin
relLine(lines[l]);
lines[l] := nil;
firstLine := cline;
lastLine := cline;
curLine := 0;
putStmnt(dprog,0,99); (* re-display old line *)
putLine;
end;
st↑.nlines := st↑.nlines - 1;
cursor := cursor - 1;
nogood := true; (* flush extra line *)
end;
end
else
begin
pp20L(' Can''t have a clause',20); pp5(' here',5); errprnt;
nogood := true;
flushp := true;
end;
end
else if filler = thentype then
begin
(* *** must be after a deproach or via clause *** *)
if (fieldNum >= 1) and (viaCl <> nil) and (viaCl↑.vcode = nil) then
begin
if nextLine.stmntp then
begin
np := addNode; (* easiest way to back up cursorStack *)
viaCl↑.next := np↑.next;
relNode(np); (* now get rid of the unneeded node *)
end;
viaCl↑.vcode := thenCode(true,getEmptyStmnt);
lcur := lcur + 1;
insertLines(cursorLine,1,1);
end
else
begin
pp20L('THEN code must be af',20); pp20('ter VIA or BY clause',20);
errprnt;
nogood := true;
flushp := true;
end;
end
else if filler = wheretype then
begin
if (fieldNum = 1) and (viaCl↑.vcode <> nil) then viaCl := nil;
if viaCl <> nil then
begin
n := clauseParse(nil,false); (* get new WHERE clause *)
if n <> nil then
begin (* add it to list *)
np := viaCl↑.vclauses;
if fieldNum = 2 then (* new head of list *)
begin n↑.next := np; viaCl↑.vclauses := n end
else if fieldNum > 2 then
begin (* add after Ith clause *)
for i := 4 to fieldNum do np := np↑.next;
n↑.next := np↑.next;
np↑.next := n;
end
else
begin (* add after last clause *)
np := addNode; (* easiest way to back up cursorStack *)
relNode(np); (* now get rid of the unneeded node *)
viaCl↑.next := nil;
np := viaCl↑.vclauses;
if np = nil then viaCl↑.vclauses := n
else
begin
while np↑.next <> nil do np := np↑.next; (* find last clause *)
np↑.next := n;
end;
n↑.next := nil;
end;
moveOrder(cursorStack[cursor-1].st);
end;
end
else
begin
pp20L('WHERE must be after ',20); pp20('a VIA or BY clause ',18);
errprnt;
nogood := true;
flushp := true;
end;
end
else if filler = defertype then
begin
getToken;
if (ttype = reswdtype) and (rtype = stmnttype) and (stmnt = cmtype) then
begin
addCmon(true);
end
else if endOfLine and (not fParse) and
nextLine.stmntp and (nextLine.st↑.stype = cmtype) then
begin
nextLine.st↑.deferCm := true;
l := cursorLine - topDline + 2;
relLine(lines[l]); (* fix up lines array *)
lines[l] := nil;
firstLine := ocur;
lastLine := lcur;
curLine := 0;
putStmnt(dprog,0,99); (* re-display old line *)
putLine;
lines[l] := lines[l-1];
lines[l-1] := nil;
nogood := (slabel = nil) and not labp; (* flush line if no label *)
if nogood then ocur := ocur + 1;
end
else
begin
pp20L(' Expecting an ON her',20); ppChar('e'); errprnt;
nogood := true;
flushp := true;
end
end
end
else if ttype = comnttype then
begin (* comment *)
(* *** need to check if it should be a statement or clause comment *** *)
addNewSt(commenttype); (* *** for now only allow statement comments *)
if stOk then
begin
sp↑.str := str; (* copy string pointer *)
sp↑.len := len;
sp↑.cbody := nil;
setUpNewStmnt;
end
end
else if endOfLine then
begin
if slabel = nil then nogood := not labp; (* delete the line if empty *)
end
else
begin
backup := true;
if declarationp then
begin
addDeclSt;
end
else if (ttype = identtype) or
((ttype = reswdtype) and (rtype = optype)) then
begin
addNewSt(assigntype);
if stOk then assignParse(sp,nil);
end
else
begin (* no good - complain *)
pp20L(' Can''t make sense of',20); pp20(' inserted text ',14); errprnt;
nogood := true;
backup := false;
flushp := true;
end;
end;
if sp <> nil then
begin
if (sp↑.nlines > 1) and (lcur > 0) then
begin
insertLines(ocur+1,sp↑.nlines-1,1); (* make room for the extra lines *)
lcur := lcur + sp↑.nlines - 1;
end
end
else if slabel <> nil then
if nextLine.stmntp then
with nextLine.st↑ do
begin
stlab := slabel;
slabel↑.s := nextLine.st;
nlines := nlines + 1;
end
else
begin pp20L(' Label has nothing t',20); pp10('o label ',7); errprnt end;
if sParse then j := 0 else j := addNewDeclarations;
if nogood and (not emptyp) and (ocur = cursorLine) then
begin
deleteLines(ocur,1,1);
end
else
begin
ocur := ocur + j;
lcur := lcur + j;
firstLine := ocur;
lastLine := lcur;
setCursor := true;
cursorLine := cursorLine + 1;
curLine := 0;
if not sParse then putStmnt(dprog,0,99) (* write & display new line *)
else
begin
cursor := sCursor - 1;
putStmnt(cursorStack[sCursor].st,0,99)
end;
if fParse then setCursor := false
else
begin
adjustDisplay; (* make sure cursor is on screen *)
displayLines(lineNum);
end;
end;
firstTime := false;
flushcomments := false; (* comments are ok here *)
if flushp then getToken;
while flushp and not endOfLine do (* in case of errors *)
begin (* leave things in a "clean" state *)
if ttype = reswdtype then
if (stOk and (rtype = stmnttype) and (stmnt <> assigntype)) or
(clOk and (rtype = filtype) and
(filler in [totype,viatype,withtype])) then
begin flushp := false; backup := true end
else getToken (* try next token *)
else if (ttype = delimtype) and (ch = ';') then flushp := false
else getToken; (* if still bad try next token *)
end;
if not sParse then (* skip semi's *)
begin
repeat getToken until (ttype <> delimtype) or (ch <> ';');
backup := true;
end
else if cursor < sCursor then
begin
cursor := sCursor;
emptyp := false;
b := not elseTest; (* ELSE ok here? *)
if not b then
begin
cursor := sCursor;
descend(cursorStack[sCursor].st); (* how about a motion clause? *)
with cursorStack[cursor].st↑ do
b := (movetype <= stype) and (stype <= floattype);
end;
if b then
begin
getToken; (* check for ELSE or clause *)
backup := true;
endOfLine := (ttype = delimtype) and (ch = ';');
end
else endOfLine := true;
cursor := sCursor;
end;
end;
until endOfLine;
flushcomments := true; (* don't allow comments anywhere else *)
if ((echar = 'U') or (echar = 'P')) and (not nogood) then
cursorLine := cursorLine - 2; (* U or P *)
again := (echar = 'N') or (echar = 'P'); (* keep going if N or P *)
if not sParse then
begin
firstTime := true;
firstLine := 0;
lastLine := -1;
setCursor := true;
curLine := 0;
putStmnt(dProg,0,99);
setCursor := false;
end;
until not again;
borderLines;
setExpr := false;
end;
(* delStmnt *)
procedure delStmnt(arg: integer);
var s,sp,so: statementp; n,np,no: nodep; v,vp: varidefp; p,pn: pdbp;
ocur,i,j,dlines: integer; b,bv,reparsep: boolean; pttype: nodetypes;
procedure resetPC(i,f:integer; st,sd: statementp);
var j,k: integer; p,pn: pdbp; b: boolean;
begin
for j := 0 to debugLevel do
begin (* make sure no process is about to execute stmnt we're deleting *)
if j = 0 then p := getAllPdbs else p := debugPdbs[j];
while p <> nil do (* run through all the active processes *)
with p↑ do
begin
pn := nextPdb;
if (i <= linenum) and (linenum < f) then
begin
(* *** check if we need to remove any fornodes from process stack *** *)
flushKids(p,false); (* flush any dependent processes *)
spc := st;
epc := nil;
mode := 0;
linenum := i;
b := false;
if procp and (sd <> nil) then
if (sd↑.stype = declaretype) then
b := (sd↑.variables↑.tbits = 2) and (pdef = sd↑.variables↑.p);
if b or (spc = nil) or ((not procp) and (sd = sdef)) then
begin (* flush the process *)
if eCurInt = p then eCurInt := debugPdbs[0];
if j = 0 then flushPdb(p)
else
begin
relPdb(p);
debugPdbs[j] := nil;
if j = debugLevel then
repeat
debugLevel := debugLevel - 1
until (debugLevel = 0) or (debugPdbs[debugLevel] <> nil);
end;
end;
end;
p := pn;
end;
end;
end;
function newEmptyStmnt: statementp;
var st: statementp; l: integer;
begin
st := newStatement;
dlines := sp↑.nlines - 1;
with st↑ do
begin
stype := emptytype;
last := cursorStack[cursor-1].st;
next := sp↑.next;
end;
if sp↑.stlab <> nil then sp↑.stlab↑.s := nil; (* label points nowhere now *)
resetPC(cursorLine,cursorLine + sp↑.nlines,st,sp);
freeStatement(sp); (* delete old body *)
ocur := cursorLine; (* so we print out empty stmnt *)
l := cursorLine - topDline + 1;
relLine(lines[l]); (* free up old line *)
lines[l] := nil;
cursorLine := cursorLine + 1;
newEmptyStmnt := st;
end;
begin
dlines := 0;
ocur := 0;
with cursorStack[cursor] do (* don't care if it's a proc def *)
if (not stmntp) and (nd↑.ntype = procdefnode) then cursor := cursor - 1
else if stmntp and (st↑.stype = cmtype) then
with cursorStack[cursor-1] do
if (not stmntp) and (nd↑.ntype = cmonnode) then cursor := cursor - 1;
with cursorStack[cursor] do
begin (* see what we're deleting *)
if not stmntp then
begin (* case labels or motion clauses *)
if nd↑.ntype = clistnode then
begin (* case labels *)
(* *** later *** *)
end
else if (cline < cursorLine) and (fieldNum = 1) then
begin (* delete THEN code *)
(* ** only VIA code for now ** *)
b := true;
while b and (nd↑.next <> nil) do (* find correct VIA/BY node *)
with nd↑.next↑ do
if (ntype = nd↑.ntype) and vlist then nd := nd↑.next else b := false;
if nd↑.vcode↑.stype = signaltype then dlines := 2
else dlines := nd↑.vcode↑.conclusion↑.nlines + 1;
resetPC(cursorLine+1,cursorLine + dlines,nil,nd↑.vcode↑.conclusion);
freeStatement(nd↑.vcode);
nd↑.vcode := nil;
end
else if (nd↑.ntype = viaptnode) and (fieldNum > 1) then
begin (* WHERE clause(s) in VIA *)
b := true;
while b and (nd↑.next <> nil) do (* find correct VIA/BY node *)
with nd↑.next↑ do
if (ntype = nd↑.ntype) and vlist then nd := nd↑.next else b := false;
b := fieldNum = 2; (* deleting first clause? *)
n := nd↑.vclauses; (* find clause in list *)
if b then np := n
else begin for i := 4 to fieldNum do n := n↑.next; np := n↑.next end;
j := 1;
while (j <= arg) and (np <> nil) do
begin (* delete them *)
with np↑ do
begin
dlines := dlines + 1; (* how many lines are we deleting *)
no := next;
next := nil; (* so freeNode doesn't clobber remaining clauses *)
end;
freeNode(np);
np := no;
j := j + 1;
end;
if b then nd↑.vclauses := np (* splice in last clauses *)
else n↑.next := np;
moveOrder(cursorStack[cursor-1].st);
end
else
begin (* motion clauses *)
np := nd;
sp := cursorStack[cursor-1].st;
n := sp↑.clauses; (* find clause in list *)
b := n = np; (* deleting first clause? *)
if (not b) and (n <> nil) then (* find clause *)
while (n↑.next <> nil) and (n↑.next <> np) do n := n↑.next;
j := 1;
while (j <= arg) and (np <> nil) do
begin (* delete them *)
if (np↑.ntype = viaptnode) or (np↑.ntype = byptnode) then
begin (* check if VIA/BY list *)
pttype := np↑.ntype;
bv := np↑.next <> nil;
while bv do
with np↑.next↑ do
if (ntype = pttype) and vlist then
begin
no := np↑.next;
bv := next <> nil;
np↑.next := nil;
freeNode(np); (* flush front part of VIA/BY list *)
np := no;
end
else bv := false;
end;
with np↑ do
begin
if ((ntype = viaptnode) or (ntype = byptnode)) and (vcode <> nil) then
if vcode↑.stype = signaltype then i := 1
else
begin
i := vcode↑.conclusion↑.nlines;
flushVar(vcode↑.cdef); (* flush the cmon variable *)
end
else if ((ntype = deprnode) or (ntype = apprnode)) and (code <> nil) then
if code↑.stype = signaltype then i := 1
else
begin
i := code↑.conclusion↑.nlines;
flushVar(code↑.cdef); (* flush the cmon variable *)
end
else if ntype = cmonnode then
begin
i := cmon↑.nlines - 1;
flushVar(cmon↑.cdef); (* flush the cmon variable *)
end
else i := 0;
dlines := dlines + i + 1; (* how many lines are we deleting *)
no := next;
next := nil; (* so freeNode doesn't clobber remaining clauses *)
end;
freeNode(np);
np := no;
j := j + 1;
end;
if b then sp↑.clauses := np (* splice in last clauses *)
else if n <> nil then n↑.next := np;
moveOrder(sp);
end
end
else
begin
sp := st;
if (sp↑.stype = iftype) and (fieldNum = 2) then
begin (* flush ELSE *)
dlines := sp↑.els↑.nlines + 1;
resetPC(cursorLine+1,cursorLine + sp↑.els↑.nlines,sp↑.next,sp↑.els);
freeStatement(sp↑.els);
sp↑.els := nil;
sp↑.nlines := sp↑.nlines - dlines;
ocur := cursorLine - 1; (* redraw above line in case it needs a ";" *)
end
else if (sp↑.stype = affixtype) and (fieldNum = 5) then
begin (* flush atexp *)
sp↑.atexp := nil;
sp↑.nlines := sp↑.nlines - 1;
dlines := 1;
ocur := cursorLine - 1; (* redraw above line in case it needs a ";" *)
end
else if (sp↑.stype in [printtype,prompttype,aborttype,saytype]) and
(fieldNum > 1) then
begin (* part of plist *)
no := sp↑.plist;
for i := 1 to fieldNum-2 do no := no↑.next;
n := no↑.next;
while (n <> nil) and (arg >= 1) do
begin
b := true;
bv := false;
i := cursorStack[cursor].ind + 7;
if sp↑.stype = saytype then i := i - 2;
while b and (n <> nil) do
begin
i := i + getExprLength(n↑.lval);
if bv and (i > 78) then b := false
else
begin
bv := true;
np := n↑.next;
if np <> nil then i := i + 1; (* account for "," *)
relExpr(n↑.lval); (* flush the old expression *)
relNode(n); (* & the plist node too *)
n := np;
end
end;
arg := arg - 1;
dlines := dlines + 1;
sp↑.nlines := sp↑.nlines - 1;
end;
no↑.next := n;
if n = nil then ocur := cursorLine - 1; (* redraw above line to add ")" *)
end
else if (sp↑.stype = endtype) or (sp↑.stype = coendtype) then
begin (* no good *)
pp20L('Can''t delete END or ',20); pp5('COEND',5); ppLine;
end
else
with cursorStack[cursor-1] do
if stmntp then
case st↑.stype of
blocktype: begin
reparsep := false;
j := 1;
b := st↑.bcode = sp; (* first stmnt in block? *)
while (j <= arg) and (sp↑.stype <> endtype) do
begin
dlines := dlines + sp↑.nlines;
if sp↑.stype = declaretype then
begin (* flush the variables *)
(* *** need to check if several instances of defining block! *** *)
reparsep := true;
v := sp↑.variables;
while v <> nil do
begin
vp := v↑.dnext;
flushVar(v);
v := vp;
end;
end
else if sp↑.stype = cmtype then
begin (* flush the cmon variable *)
(* *** need to check if several instances of defining block! *** *)
flushVar(sp↑.cdef);
end
else if sp↑.stype = dimdeftype then
begin (* flush the dimension variable *)
flushVar(sp↑.dimname);
end
else if sp↑.stype = definetype then
begin (* flush the macro variable *)
flushVar(sp↑.macname);
end;
so := sp↑.next;
so↑.last := sp↑.last; (* splice block out of list *)
if b then st↑.bcode := so else sp↑.last↑.next := so;
if sp↑.stlab <> nil then sp↑.stlab↑.s := nil; (* update label *)
resetPC(cursorLine,cursorLine+dlines,sp↑.next,sp);
freeStatement(sp); (* delete it *)
sp := so;
j := j + 1;
end;
if reparsep then
begin (* need to reparse block *)
for i := 1 to cursor - 1 do (* update cursor stack *)
with cursorStack[i] do
if stmntp then st↑.nlines := st↑.nlines - dlines;
reParse(curBlock);
if dprog↑.nlines < dispHeight then
for i := dprog↑.nlines + 1 to dprog↑.nlines + dlines do
if i <= dispHeight then clearLine(i+1);
delUpdate(dlines);
dlines := 0; (* reParse will fix up the screen *)
end;
end;
coblocktype: (* should never get here *);
iftype: if st↑.thn = sp then st↑.thn := newEmptyStmnt
else st↑.els := newEmptyStmnt;
fortype: st↑.fbody := newEmptyStmnt;
whiletype,
untiltype: st↑.body := newEmptyStmnt;
cmtype: st↑.conclusion := newEmptyStmnt;
end
else if nd↑.ntype = colistnode then
begin (* coblock *)
so := sp↑.last;
j := 1;
repeat
dlines := dlines + sp↑.nlines;
if sp↑.stlab <> nil then sp↑.stlab↑.s := nil; (* update label *)
resetPC(cursorLine,cursorLine+dlines,nil,sp);
freeStatement(sp); (* delete it *)
n := nd↑.next;
if so↑.nthreads = 1 then (* only statement in coblock? *)
nd↑.cstmnt := newEmptyStmnt (* yes - replace with an empty stmnt *)
else
begin (* flush node *)
so↑.nthreads := so↑.nthreads - 1;
if nd↑.next <> nil then nd↑.next↑.prev := nd↑.prev;
if nd↑.prev <> nil then nd↑.prev↑.next := nd↑.next
else so↑.threads := nd↑.next;
relNode(nd);
end;
j := j + 1;
if n <> nil then begin nd := n; sp := nd↑.cstmnt end;
until (j > arg) or (n = nil);
end
else
begin (* case list *)
(* *** later *** *)
end
end
end;
if dlines > 0 then deleteLines(cursorLine,dlines,1); (* fix up display *)
firstLine := ocur;
if ocur > 0 then lastLine := ocur else lastLine := -1;
setCursor := true;
curLine := 0;
putStmnt(dProg,0,99); (* reset cursor & possibly redraw a line *)
setCursor := false;
setECurInt;
borderLines;
end;
(* bracketStmnt *)
procedure bracketStmnt;
var sbeg,sp: statementp; n: nodep; i: integer;
begin
with cursorStack[cursor] do
if (not stmntp) or (fieldNum > 1) then
begin pp20L('Need to be at a stat',20); pp5('ement',5); ppLine end
else if (st↑.stype = endtype) or (st↑.stype = coendtype) or (cursor=2) then
begin pp20L('Can''t enclose statem',20); pp5('ent ',3); ppLine end
else
begin
cursorLine := cline; (* in case labelled statement *)
for i := 1 to cursor-1 do
with cursorStack[i] do
if stmntp then st↑.nlines := st↑.nlines + 2;
sp := st;
sbeg := newStatement;
with sbeg↑ do
begin
stype := blocktype;
nlines := sp↑.nlines + 2;
next := sp↑.next;
last := sp↑.last;
sp↑.last := sbeg;
appendEnd(sbeg,sp);
bcode := sp;
bparent := curBlock;
blkid := nil;
level := curBlock↑.level + 1;
numvars := 0;
variables := nil;
end;
with cursorStack[cursor-1] do
if stmntp then
case st↑.stype of
blocktype: begin
sbeg↑.next↑.last := sbeg; (* splice us into block *)
with sbeg↑.last↑ do (* check for start of block *)
if next = sp then next := sbeg else bcode := sbeg;
end;
iftype: begin
if st↑.thn = sp then st↑.thn := sbeg else st↑.els := sbeg;
end;
cmtype: begin
st↑.conclusion := sbeg;
end;
whiletype,
untiltype: st↑.body := sbeg;
fortype: st↑.fbody := sbeg;
end
else
case nd↑.ntype of
clistnode: begin
n := nd;
while n <> nil do
if n↑.stmnt = sp then begin n↑.stmnt := sbeg; n := n↑.clast end
else n := nil;
end;
colistnode: begin
nd↑.cstmnt := sbeg;
end;
procdefnode: begin
nd↑.body := sbeg;
sbeg↑.level := nd↑.level + 1;
end;
end;
insertLines(cursorLine,1,-1);
firstLine := cursorLine;
lastLine := firstLine;
cursorLine := cursorLine + 1;
setCursor := true;
curLine := 0;
putStmnt(dprog,0,99); (* display BEGIN & update cursor *)
setCursor := false;
if cursorLine + sp↑.nlines <= botDline then
begin
firstLine := cursorLine + sp↑.nlines;
lastLine := firstLine;
insertLines(firstLine,1,-1);
curLine := 0;
putStmnt(dprog,0,99); (* display END *)
end;
borderLines;
end;
end;
(* aux routines: mark, unmark & gotoMark *)
procedure mark;
var i,j: integer;
begin
if nmarks >= 20 then
begin pp20L('Sorry - mark table f',20); pp5('ull ',3); ppLine end
else
begin
i := 1;
while (i <= nmarks) and (cursorLine > marks[i]) do i := i + 1;
if cursorLine = marks[i] then
begin pp20L('Already marked ',14); ppLine end
else
begin
for j := nmarks downto i do marks[j+1] := marks[j];
nmarks := nmarks + 1;
marks[i] := cursorLine;
end;
end;
end;
procedure unmark(all: boolean);
var i,j: integer;
begin
if all then
begin (* delete all marks *)
if nmarks = 0 then
begin pp20L('There are no marks ',18); ppLine end
else
begin
for i := 1 to 20 do marks[i] := 0;
nmarks := 0;
end
end
else
begin
i := 1;
while (i <= nmarks) and (cursorLine > marks[i]) do i := i + 1;
if (i > nmarks) or (cursorLine < marks[i]) then
begin pp10L('Not marked',10); ppLine end
else
begin
for j := i to nmarks-1 do marks[j] := marks[j+1];
marks[nmarks] := 0;
nmarks := nmarks - 1;
end;
end;
end;
procedure gotoMark(n: integer);
var i: integer;
begin
if nmarks = 0 then
begin pp20L('There are no marks ',18); ppLine end
else if n = 0 then
begin pp10L('There are ',10); ppInt(nmarks); pp10(' marks ',6); ppLine end
else
begin
i := 1;
while (i <= nmarks) and (cursorLine > marks[i]) do i := i + 1;
if (n > 0) and (cursorLine < marks[i]) then n := n - 1;
i := ((i + n - 1) mod nmarks) + 1;
if i <= 0 then i := i + nmarks;
cursorLine := marks[i];
end;
end;
(* aux routine: setPPSize, flushOldEnvironments, saveOutermostEnv *)
procedure setPPSize(arg: integer);
var delta,i,j,top,bot: integer;
begin (* set page printer size to arg *)
if arg < 3 then arg := 3 (* make sure it's a reasonable request *)
else if arg > screenHeight - 5 then arg := screenHeight - 5;
if arg > maxPPlines then arg := maxPPlines;
delta := arg - ppSize;
if delta > 0 then
begin (* increase page printer size *)
ppOffset := ppOffset + delta;
dispHeight := dispHeight - delta;
adjustDisplay; (* make sure cursor stays on screen *)
displayLines(lineNum); (* shift display if necessary *)
for i := ppSize downto 1 do ppLines[i+delta] := ppLines[i];
for i := 1 to delta do
begin
ppLines[i] := nil; (* we'll roll up later *)
clearLine(dispHeight + 1 + i);
end;
end
else if delta < 0 then
begin (* decrease page printer size *)
delta := - delta;
ppOffset := arg;
for i := 1 to delta do relLine(ppLines[i]);
for i := 1 to arg do ppLines[i] := ppLines[delta + i];
for i := arg + 1 to ppSize do ppLines[i] := nil;
for i := 1 to delta do clearLine(dispHeight + 1 + i);
top := topDline + firstDline + dispHeight - 1; (* top line being added *)
bot := top + delta - 1; (* last line to add *)
if bot <= botDline then j := bot else j := botDline;
for i := top to j do (* show lines already in display *)
with lines[i-topDline+1]↑ do
out1Line(i-topDline-firstDline+2,start,length);
dispHeight := dispHeight + delta;
if j < bot then displayLines(lineNum) (* add new lines *)
else borderLines;
end;
ppSize := arg;
end;
procedure flushOldEnvironments (* dLev: integer *);
var i: integer; p: pdbp;
begin (* tell INTERP to flush old program environment *)
for i := debugLevel downto dLev do
begin
if i > 0 then
begin
p := debugPdbs[i];
while p <> nil do
with p↑ do
begin
if sdef↑.last = nil then (* free immediate stmnt & it's abort *)
begin freeStatement(sdef↑.next); freeStatement(sdef) end
else
with sdef↑.next↑ do
if (stype = aborttype) and (debugLev >= i) then
begin
last↑.next := next;
next↑.last := last;
freeStatement(sdef↑.next); (* flush pseudo-abort *)
end;
p := next;
end;
flushAll(debugPdbs[i],i);
debugPdbs[i] := nil;
end
else flushAll(nil,0);
end;
if tSingleThreadMode and (STLevel >= dLev) then
begin
STLevel := 0;
tSingleThreadMode := false;
if not singleThreadMode then setSingleThreadMode(false);
end;
if dLev > 0 then debugLevel := dlev - 1 else debugLevel := 0;
if getCurInt = nil then swap(nil); (* see if anyone's active *)
eCurInt := getCurInt;
if eCurInt <> nil then pcLine := eCurInt↑.linenum;
end;
procedure saveOutermostEnv;
var menv: envheaderp;
begin
with debugPdbs[0]↑ do (* use main process pdb *)
begin
menv := env; (* save outermost environment *)
level := 2; (* so flushAll won't clobber it *)
end;
while menv↑.parent↑.parent <> nil do
menv := menv↑.parent; (* up to outermost environment *)
flushOldEnvironments(0);
singleThreadMode := false; (* reset single thread (nowait) mode)
eCurInt := getCurInt; (* get new main process pdb *)
debugPdbs[0] := eCurInt;
with eCurInt↑ do
begin
spc := dprog↑.pcode↑.bcode;
env := menv; (* restore old environment *)
sdef := dprog;
linenum := 2;
end;
pcLine := 2;
end;
(* aux routine: fileParse, writeProg, readProg *)
procedure fileParse(var fname: cstring; var ppn: integer);
var ip,i,j,k,prj,prg: integer; ch: char;
procedure sixbit(ch: ascii; var ppn: integer);
begin
if ppn < 10000B then ppn := ppn * 100B + (ord(ch) - ord(' '))
else begin pp10L('Bad ppn ',7); ppLine; end;
end;
function nextchar: char;
begin
if i <= maxChar then nextchar := upperCase(listing[i])
else nextchar := ' ';
i := i + 1;
end;
begin
fname[1] := ' ';
i := curChar;
k := maxChar + 1;
ip := 1;
prj := 0;
prg := 0;
repeat ch := nextchar until ch <> ' ';
while (ch <> '.') and (ch <> '[') and (ch <> ' ') and (i <= k) do
begin (* parse file name *)
if ip <= 6 then begin fname[ip] := ch; ip := ip + 1 end
else begin pp20L('Bad file name ',13); ppLine; end;
ch := nextchar;
end;
for j := ip to 6 do fname[j] := ' ';
ip := 7;
if ch = '.' then (* parse file extension *)
begin
ch := nextchar;
while (ch <> '[') and (ch <> ' ') and (i <= k) do
begin
if ip <= 9 then begin fname[ip] := ch; ip := ip + 1 end
else begin pp20L('Bad file extension ',18); ppLine; end;
ch := nextchar;
end;
end;
for j := ip to 9 do fname[j] := ' ';
if ch = '[' then (* parse ppn *)
begin
ch := nextchar; (* skip over '[' *)
while (ch <> ',') and (i <= k) do
begin
sixbit(ch,prj);
ch := nextchar;
end;
if prj >= 400000B then prj := (prj - 400000B) * 1000000B + 400000000000B
else prj := prj * 1000000B;
ch := nextchar; (* skip over comma *)
while (ch <> ']') and (i <= k) do
begin
sixbit(ch,prg);
ch := nextchar;
end;
end;
ppn := prj + prg;
end;
procedure writeProg;
var i,j,ppn: integer; filnam: cstring; fname: packed array [1..9] of char;
b: boolean; ch: ascii;
begin
fileParse(filnam,ppn);
if filnam[1] <> ' ' then
begin
for i := 1 to 9 do fname[i] := filnam[i];
reset(outFile,fname,0,ppn); (* see if file already exists *)
b := eof(outFile);
if not b then
begin (* yes - it does *)
pp20('File already exists ',20); pp20('- type "Y" to overwr',20);
pp10('ite it: ',9); ppOutNow;
i := 1;
ch := exprEditor(dispHeight+ppOffset+1,1,ppBufp,ppBufp,i,0);
if smartTerminal then (* deboldify it *)
outLine(dispHeight+ppOffset+1,ppBufp,ppBufp,i);
for j := ppBufp to ppBufp+i-1 do ppBuf[j] := listing[j];
j := ppBufp;
ppBufp := ppBufp + i - 1;
while (listing[j] = ' ') and (j < ppBufp + i - 1) do j := j + 1;
b := (listing[j] = 'Y') or (listing[j] = chr(171B)); (* 'Y' or 'y' *)
if not b then pp10(' - Aborted',10);
ppLine;
end;
if b then
begin
rewrite(outFile,fname,0,ppn); (* open file *)
outFilep := true;
firstLine := 0;
lastLine := dprog↑.nlines + 1;
curLine := 0;
putStmnt(dprog,0,99); (* write program out *)
outFilep := false;
break(outFile);
reset(outFile); (* close file *)
end;
end
else begin pp20L('Need a name for file',20); ppLine end;
end;
procedure readProg;
var i,ppn: integer; filename: cstring; b: boolean;
fname: packed array [1..9] of char;
begin
fileParse(filename,ppn);
if filename[1] <> ' ' then
begin
for i := 1 to 9 do fname[i] := filename[i];
reset(file1,fname,0,ppn); (* see if file exists *)
b := eof(file1); (* does it? *)
if b and (fname[7] = ' ') and (fname[8] = ' ') and (fname[9] = ' ') then
begin (* no extension given, try again with .AL ext *)
fname[7] := 'A';
fname[8] := 'L';
filename[7] := 'A';
filename[8] := 'L';
reset(file1,fname,0,ppn); (* see if file exists *)
b := eof(file1); (* does it? *)
end;
if b then
begin pp20L('File not found ',15); ppLine end
else
begin
freeStatement(dprog); (* release old program *)
flushOldEnvironments(0);
makeOuterBlock; (* & make new one *)
curLine := 0;
cursor := 0;
pushStmnt(dprog,1); (* set up cursor stack *)
pushStmnt(dprog↑.pcode,0);
curPage := 1;
curFLine := 1;
pushStmnt(dprog↑.pcode↑.bcode,0); (* now push the block's END *)
cursorLine := 2;
i := ppSize;
setPPSize(55); (* use max pp size *)
clearLine(4);
fParse := true;
filedepth := 1;
errCount := 0;
readLine; (* get first line of program *)
flushcomments := true; (* don't want any comments yet *)
getToken; (* check for outer block *)
with curToken do
if (ttype = reswdtype) and (rtype = stmnttype) and
(stmnt = blocktype) then dprog↑.pcode↑.blkid := getBlkId
else backup := true;
addStmnt(false); (* read in new program *)
fParse := false;
filedepth := 0;
if errcount = 0 then pp20L('No errors detected ',18)
else begin pp20L('Errors detected: ',17); ppInt(errcount) end;
ppLine;
setUpStmnt;
setCursor := true;
cursorLine := 2;
lineNum := 1;
topDline := 0;
botDline := 0;
displayLines(lineNum); (* show first window *)
setPPSize(i);
end;
reset(file1); (* all done with file now *)
end
else begin pp20L('Need a name of file ',19); ppLine end;
end;
(* aux routine: varDefine *)
procedure varDefine;
var vp: varidefp; n,np: nodep; s: statementp; b: boolean; i: integer;
begin
b := true;
if (cursorStack[cursor].stmntp) and
(cursorStack[cursor-1].stmntp) then
if cursorStack[cursor-1].st↑.stype = blocktype then
begin
b := false;
getToken;
with curToken do
while ttype = identtype do
begin
vp := varLookup(id); (* look up the variable *)
if vp <> nil then
if vp↑.tbits <> 2 then (* make sure its not a procedure *)
begin
backup := true;
np := exprParse; (* now go turn it into a node *)
s := newStatement;
with s↑ do (* make up a new assignment stmnt *)
begin
stype := evaltype;
what := np;
next := s; (* so dFreePdb doesn't flush us *)
last := s;
exprs := evalorder(np,nil,true); (* we want its current value *)
executeStmnt(s); (* aval will be set by INTERP *)
stype := assigntype;
(* *** if vector then should append dimension info, but... *** *)
with aval↑ do
if (ltype = vectype) or (ltype = transtype) then
v↑.refcnt := v↑.refcnt + 1; (* so it doesn't disappear *)
with what↑ do
if ntype = leafnode then np := nil
else if op = arefop then np := arg2
else if arg1↑.ntype = leafnode then np := nil
else np := arg1↑.arg2;
if np <> nil then
np := evalorder(np,nil,true); (* deal with subscripts *)
exprs := evalorder(aval,np,true);
end;
with cursorStack[cursor] do
begin
s↑.next := st; (* splice in the assignment statement *)
s↑.last := st↑.last;
st↑.last := s;
with s↑.last↑ do
if next = st then next := s else bcode := s;
i := cline;
cline := cline + 1; (* update where cursor now is *)
cursorLine := cline;
end;
insertLines(i,1,1); (* make space in display for it *)
firstLine := i;
lastLine := i;
setCursor := false;
curLine := 0;
putStmnt(dProg,0,99); (* write & display new line *)
adjustDisplay; (* make sure cursor is on screen *)
displayLines(lineNum);
end
else
begin
pp20L('Can''t assign to proc',20); pp10('edure: ',7);
prntStrng(id↑.length,id↑.name);
pp20(' -- will ignore it. ',19); ppLine;
end
else
begin
pp20L('Undefined variable: ',20);
prntStrng(id↑.length,id↑.name);
pp20(' -- will ignore it. ',19); ppLine;
end;
getToken;
if not endOfLine then
begin backup := true; getDelim(',') end;
getToken; (* get next variable name *)
end;
end;
if b then
begin
pp20('Can''t insert an assi',20); pp20('gnment here - Sorry.',20);
ppLine;
end;
end;
(* routines for breakpoints: setBpt,clrBpt,clrAllBpts,setTBpt,stepStmnt,clrTBpts *)
procedure setBpt(st: statementp);
var i: integer;
begin
if not st↑.bpt then (* don't do anything if bpt already set *)
begin
nbpts := nbpts + 1;
if nbpts > maxBpts then
begin
pp20L('Gack - too many BPTs',20); ppLine;
bpts[1]↑.bpt := false; (* flush oldest bpt *)
for i := 2 to maxBpts do bpts[i-1] := bpts[i];
nbpts := maxBpts;
end;
bpts[nbpts] := st;
st↑.bpt := true;
end;
end;
procedure clrBpt(st: statementp);
var i: integer; b: boolean;
begin
if st↑.bpt then (* don't do anything if bpt not set *)
begin
b := true;
for i := 1 to nbpts do
if b then b := bpts[i] <> st (* first find statement in list *)
else bpts[i-1] := bpts[i]; (* then compact the list *)
if not b then
begin
st↑.bpt := false; (* clear it only if we set it *)
bpts[nbpts] := nil;
nbpts := nbpts - 1;
end;
(* else wonder how the bpt got set? *)
end;
end;
procedure clrAllBpts;
var i: integer;
begin
for i := 1 to nbpts do
begin bpts[i]↑.bpt := false; bpts[i] := nil end;
nbpts := 0;
end;
procedure setTBpt(st: statementp);
var i: integer;
begin
with st↑ do
if not bpt then (* don't do anything if bpt already set *)
begin
ntbpts := ntbpts + 1;
if ntbpts > maxTBpts then
begin
pp20L('Gack - too many temp',20); pp10('orary BPTs',10); ppLine;
tbpts[1]↑.bpt := false; (* flush oldest bpt *)
for i := 2 to maxTBpts do tbpts[i-1] := tbpts[i];
ntbpts := maxTBpts;
end;
tbpts[ntbpts] := st;
bpt := true;
end;
end;
procedure stepStmnt(bpttype: integer);
var i: integer; st: statementp; n: nodep;
procedure setTBptsAux(st: statementp);
begin
if st <> nil then
with st↑ do
if stype = endtype then
begin
if bparent↑.stype = fortype then setTBpt(bparent↑.fbody)
else if bparent↑.stype <> cmtype then setTBpt(bparent)
else setTBpt(bparent↑.conclusion); (* do we really want this??? *)
if bparent↑.next <> nil then setTBptsAux(bparent↑.next);
if bparent↑.stype = blocktype then setTBpt(st);
end
else if stype = coendtype then setTBpt(st↑.bparent↑.next)
else if (stype = returntype) and (next = nil) and eCurInt↑.procp then
begin (* appended return *)
setTBptsAux(eCurInt↑.opdb↑.spc↑.next) (* stop after we get back *)
end
else setTBpt(st);
end;
begin
(* bpttype = 1 single step descending to lower levels + procedure calls
(* = 2 " " " " " " + no procedure calls
(* = 3 " " but stay at current level
(* = 4 step up to next higher lexical level *)
st := eCurInt↑.spc; (* find where we're stepping from *)
with st↑ do
if stype = progtype then st := pcode;
if bpttype <= 3 then
begin
if bpttype = 1 then
begin (* look if any procedure calls in st↑.exprs *)
n := st↑.exprs;
while n <> nil do
with n↑ do
if (ntype = exprnode) and (op = callop) then
begin (* set a bpt at first statement in procedure *)
setTBpt(arg1↑.vari↑.p↑.body);
n := nil;
end
else n := next;
end;
if bpttype <= 2 then
with st↑ do (* look if can descend down a level *)
case stype of
blocktype: setTBpt(bcode);
coblocktype:setTBpt(threads↑.cstmnt); (* always goes there first *)
fortype: setTBpt(fbody);
whiletype,
untiltype: setTBpt(body);
casetype: begin
n := caselist;
while n <> nil do begin setTBpt(n↑.stmnt); n := n↑.next end;
end;
iftype: begin
setTBpt(thn);
if els <> nil then setTBpt(els);
end;
cmtype: setTBpt(conclusion);
others: begin end; (* nothing to do *)
(* *** what about cmon's & then code in motion statements ??? *** *)
end;
if (st↑.stype = returntype) and eCurInt↑.procp then
begin (* figure out where procedure returns to *)
if bpttype = 1 then
begin (* check if expression will call another proc *)
n := eCurInt↑.epc;
while n <> nil do
with n↑ do
if (ntype = exprnode) and (op = callop) then
begin (* set a bpt at first statement in procedure *)
setTBpt(arg1↑.vari↑.p↑.body);
n := nil;
end
else n := next;
end;
setTBptsAux(eCurInt↑.opdb↑.spc↑.next) (* stop after we get back *)
end
else
begin
setTBptsAux(st↑.next); (* just stop at next stmnt *)
setTBptsAux(st); (* in case we're the body of a loop *)
end;
end
else
begin (* deal with going up a level *)
while st <> nil do
if (st↑.stype<>coendtype) and (st↑.stype<>endtype) then st := st↑.next
else
with st↑.bparent↑ do
if stype = progtype then st := nil
else if (stype = blocktype) or (stype = fortype) then
begin setTBptsAux(next); st := nil end
else begin setTBptsAux(st); st := nil end;
if eCurInt↑.procp then (* we may exit the procedure *)
setTBptsAux(eCurInt↑.opdb↑.spc↑.next); (* so stop after we get back *)
end;
end;
procedure clrTBpts;
var i: integer;
begin
for i := 1 to ntbpts do
begin tbpts[i]↑.bpt := false; tbpts[i] := nil end;
ntbpts := 0;
end;
(* debugging routines: dGetPdb,dfreePdb,getPCline,runStmnt,executeStmnt,pevalExpr,goStmnt *)
function dGetPdb(st: statementp): pdbp;
var p: pdbp;
begin
p := newPdb;
debugPdbs[debugLevel] := p; (* add us to list of all debugger processes *)
with p↑ do
begin (* initialize it somewhat *)
nextPdb := nil;
next := nil;
env := eCurInt↑.env;
level := getELev(env) + 1;
priority := 10 * debugLevel; (* use priority level for debug level *)
cm := eCurInt↑.cm;
mech := eCurInt↑.mech;
status := nullqueue;
mode := 0;
spc := st;
epc := nil;
sp := nil;
procp := false;
if eCurInt↑.procp then opdb := eCurInt else opdb := nil; (* for RETURN *)
sdef := st; (* so we can easily release it later *)
linenum := 0;
end;
dGetPdb := p;
end;
procedure dfreePdb(p: pdbp);
begin (* remove pdb from list *)
with p↑ do
if (spc↑.stype = aborttype) and (spc↑.debugLev >= debugLevel) then
begin
with spc↑ do
if spc↑.last↑.last = nil then freeStatement(spc↑.last) (* can flush it *)
else
begin
last↑.next := next; (* splice abort out now *)
next↑.last := last;
end;
freeStatement(spc);
end;
debugPdbs[debugLevel] := nil;
relPdb(p);
end;
function getPCline(st: statementp): integer;
begin
if st = nil then getPCline := 1
else if st↑.stype = progtype then getPCline := 1
else
begin
findStmnt := st;
setCursor := false;
curLine := 0;
firstLine := 0;
lastLine := -1;
if debuglevel = 0 then findLine := 1 else findLine := 0;
putStmnt(dprog,0,99); (* find line cursor is on *)
getPCline := findLine;
end;
end;
procedure runStmnt;
var p: pdbp; b,bp: boolean; st: statementp; i: integer;
begin
flushLevel(debugLevel+1); (* Get rid of any previous garbage *)
Interp(debugLevel); (* Go interpret it *)
if ppBufp > 0 then ppLine;
bp := true;
p := getCurInt;
if p <> nil then
with p↑ do
if (debugLevel > 0) and (priority >= 10 * debugLevel) and (spc <> nil) then
if (spc↑.stype = aborttype) and (spc↑.debugLev >= debugLevel) then
begin (* immediate executed stmnt *)
dfreePdb(p);
swap(nil); (* swap in next active process *)
p := getCurInt; (* & see what we've got *)
bp := false;
end;
b := true;
while (debugLevel > 0) and b do
if debugPdbs[debugLevel] = nil then debugLevel := debugLevel - 1
else b := false;
if (debugLevel < STLevel) and tSingleThreadMode then
begin
STLevel := 0;
tSingleThreadMode := false;
if not singleThreadMode then setSingleThreadMode(false);
end;
if debugLevel > 0 then
begin pp10('Level: ',7); ppInt(debugLevel); ppChar('.') end;
if p <> nil then
begin
st := p↑.spc;
eCurInt := p; (* remember current context *)
end
else
begin
(* Must have been an escape-I abort with all processes currently swapped out *)
if bp then (* only complain first time through *)
begin pp20('No processes current',20); pp10('ly active.',10); ppLine end;
st := dprog↑.pcode; (* stick us at beginning *)
eCurInt := debugPdbs[0]; (* and use outermost level for now *)
eCurInt↑.linenum := 2;
end;
if not bp then pcLine := eCurInt↑.linenum;
if eCurInt↑.priority >= 10 * debugLevel then
if st↑.bpt then
begin
b := true;
if st↑.stype = endtype then
if bp and (st↑.bparent = dprog↑.pcode) then
begin
pp10('All Done ',9);
b := false;
p↑.spc := dprog↑.pcode↑.bcode; (* proceed will take it from the top *)
end;
if b and bp then
begin pp10('BPT ',4); ppOutNow end; (* say we've hit a bpt *)
end
else if st↑.bad then
begin pp20('Attempt to execute B',20); pp20('AD statement! ',13);
ppLine end; (* complain *)
clrTBpts; (* clear any temporary bpts *)
if bp then
begin
i := getPCline(st);
if i > 0 then
begin
pcLine := i;
setCursor := true;
cursorLine := pcLine;
adjustDisplay;
displayLines(lineNum); (* shift display if necessary *)
end;
end;
for i := 1 to 2 do
begin
if i = 1 then p := getAllPdbs
else if debugLevel > 0 then p := debugPdbs[debugLevel] else p := nil;
while p <> nil do (* run through all the active processes *)
with p↑ do (* & see where they are now *)
begin
if priority >= 10 * debuglevel then linenum := getPCline(spc);
p := nextPdb;
end;
end;
end;
procedure executeStmnt (* st: statementp *);
var p: pdbp; sp: statementp;
begin
debugLevel := debugLevel + 1; (* move us to a new debugging level *)
p := dGetPdb(st); (* get a new process with same environment as curInt *)
sp := newStatement;
with sp↑ do
begin
stype := aborttype;
debugLev := debugLevel;
plist := nil;
nlines := 0;
last := st;
next := st↑.next;
end;
st↑.next := sp; (* splice in pseudo-abort stmnt *)
if sp↑.next <> nil then sp↑.next↑.last := sp;
swap(p); (* swap us in *)
runStmnt; (* have interpreter do it *)
setECurInt;
end;
procedure pevalExpr(n: nodep);
var peval: statementp; b: boolean; np,no: nodep; i: integer;
begin
if n <> nil then
begin
peval := newStatement;
with peval↑ do
begin
if (n↑.ntype = exprnode) and (n↑.op = callop)
then b := n↑.arg1↑.vari↑.vtype = nulltype
else b := false;
if b then
begin
stype := calltype;
what := n;
end
else if (n↑.ntype = exprnode) and (n↑.op = dacop) then
begin
stype := assigntype;
what := n;
end
else
begin
stype := printtype;
plist := newNode;
with peval↑.plist↑ do
begin ntype := listnode; next := nil; lval := n end;
n := plist;
no := n;
with curToken do
while (ttype = delimtype) and (ch = ',') do
begin
np := newNode;
with np↑ do
begin ntype := listnode; next := nil; lval := exprParse end;
if np↑.lval = nil then freeNode(np)
else
begin
no↑.next := np; (* add a new expression to the list *)
no := np;
end;
getToken; (* look for "," *)
end;
end;
exprs := evalOrder(n,nil,false);
i := addNewDeclarations;
executeStmnt(peval); (* have interpreter eval & print it out *)
end;
end;
end;
procedure goStmnt;
var i,j: integer; b: boolean;
begin
(* *** should do more checking so we don't get in big trouble, but.... *** *)
(* *** like jumping into a procedure body, etc. *** *)
i := cursor;
b := false;
repeat
with cursorStack[i] do
if stmntp then b := st↑.stype = blocktype;
if not b then i := i - 1;
until b or (i = 0);
if b then
begin (* unwind any inner blocks *)
j := cursorStack[i].st↑.level;
if getELev(eCurInt↑.env) > j then unwind(eCurInt,j);
end;
flushKids(eCurInt,false); (* flush any processes we had sprouted *)
if not tSingleThreadMode then
begin (* see if within a cobegin thread *)
for i := 3 to cursor do
with cursorStack[i] do
if not stmntp then
if nd↑.ntype = colistnode then tSingleThreadMode := true;
if tSingleThreadMode then
if eCurInt↑.procp or (eCurInt↑.evt = nil) then
begin (* not currently in an active thread *)
STLevel := eCurInt↑.priority div 10;
setSingleThreadMode(true);
end
else tSingleThreadMode := false;
end;
with eCurInt↑ do
begin
spc := cursorStack[cursor].st;
mode := 0;
epc := nil;
debugLevel := priority div 10; (* pop up to our level (oh???) *)
end;
swap(eCurInt);
runStmnt; (* Go from where ever we are *)
end;
(* debugging routines: tracePdb, trace, setECurInt *)
procedure tracePdb(p: pdbp);
var n,np: nodep;
begin
if p = getCurInt then pp10('(active) ',9);
with p↑ do
case status of
nowrunning,
runqueue: pp10('running ',8);
inputqueue: pp20('input wait ',11);
eventqueue: pp20('event wait ',11);
forcewait: pp20('force sensing wait ',19);
sleepqueue: pp10('sleeping ',9);
joinwait: pp20('process join wait ',18);
devicewait: pp20('motion wait ',12);
end;
while p↑.procp do
begin
with p↑.pdef↑.pname↑.name↑ do
ppStrng(length,name); (* tell procedure name *)
pp5(': ',2);
ppInt(p↑.linenum);
if ppbufp > 60 then ppLine else pp5(' ',3);
p := p↑.opdb;
end;
if p↑.cm <> nil then pp10('(cmon)/ ',7) (* ??? tell anything else ??? *)
else if p↑.linenum = 0 then pp10('(tty:)/***',10)
else pp10('(main)/ ',7);
if p↑.linenum > 0 then ppInt(p↑.linenum);
ppLine;
end;
procedure trace(all: boolean);
var i,j: integer;
procedure traceAux(p: pdbp; plev: integer);
begin
if p <> nil then
with p↑ do
begin
traceAux(p↑.nextpdb,plev); (* do the oldest first *)
if (status <> nullqueue) and (status <> proccall) and
(priority >= 10 * plev) then
begin
pp10L('Process ',8); ppInt(i); ppChar(' ');
tracePdb(p);
i := i + 1;
end;
end;
end;
begin
if all then
begin
i := 1;
for j := debugLevel downto 0 do
begin
if j > 0 then
begin
pp20L('Immediate execution ',20); pp10('level: ',7);
ppInt(j); ppLine;
end
else if debugLevel > 0 then
begin pp20L('Program execution ',17); ppLine end;
if j > 0 then traceAux(debugPdbs[j],j);
traceAux(getAllPdbs,j);
end;
end
else
begin
tracePdb(eCurInt);
end;
end;
procedure setECurInt;
var i,j: integer;
procedure thisPdb(p: pdbp);
begin
with cursorStack[i] do
repeat
with p↑ do
if (priority div 10) = j then (* only look at one level at a time *)
if stmntp and (not procp) then
begin
if cm <> nil then
begin
if (st↑.stype = cmtype) and (st = cm↑.cmon) then eCurInt := p;
end
else if st = sdef then eCurInt := p
end
else if (nd↑.ntype = procdefnode) and procp then
if nd = pdef then eCurInt := p;
p := p↑.nextpdb;
until (eCurInt <> nil) or (p = nil);
end;
begin
eCurInt := nil;
j := debugLevel;
repeat
i := cursor;
repeat
if j > 0 then thisPdb(debugPdbs[j]);
if (eCurInt = nil) then thisPdb(getAllPdbs);
i := i - 1;
until (eCurInt <> nil) or (i = 0);
j := j - 1;
until (eCurInt <> nil) or (j < 0);
if eCurInt = nil then eCurInt := debugPdbs[0];
end;
(* edit: aux routines: getCChar,getEcmd,doSetCmd,collectStmnt,atStmnt,doAtCmd *)
procedure edit;
var s,sp: statementp; done,b,minus,okp: boolean; n: nodep;
i,j,k,arg,oldcline,oldline,oc,ol,iCh: integer; ch: ascii;
function getCChar: ascii;
var ch: ascii; iCh: integer;
begin
repeat ch := getChar until ord(ch) <> LF; (* read in next char *)
if (ord(ch) = deletekey) or (ord(ch) = (deletekey+128)) then
ch := chr(ctlH) (* convert SAIL <bs> to ASCII <bs> *)
else if ord(ch) = sailundline then ch := chr(undline); (* SAIL underbar *)
iCh := ord(ch);
if (version = 10) and (iCh >= 128) then
begin (* SAIL cntl char *)
if ((ord('A')+128) <= iCh) and (iCh <= (ord('Z')+128)) then
iCh := iCh - (ord('@')+128) (* make into cntl-char *)
else if ((smallA+128) <= iCh) and (iCh <= (smallZ+128)) then
iCh := iCh - (127+smallA)
else if chr(iCh-128) in [' ','↑','<','>','[','?','@','!'] then
iCh := iCh - 128
else if iCh = (ord('\')+128) then iCh := ctlBslash
else if iCh = (VT+128) then iCh := ctlU (* make ↑vt into ↑U *)
else if iCh = (FF+128) then iCh := ctlW; (* make ↑ff into ↑W *)
ch := chr(iCh);
end;
if (iCh < ord(' ')) and (iCh <> CR) then
begin (* ASCII cntl char *)
ppChar('↑');
iCh := iCh + ord('@'); (* Convert to normal char *)
end;
ppChar(chr(iCh)); (* echo it to page printer *)
ppOutNow;
getCChar := ch;
end;
procedure getEcmd;
begin
getToken; (* see what user wants us to do *)
with curToken do
if ttype = reswdtype then (* may need to change to edit context *)
if rtype = stmnttype then
begin
if stmnt = definetype then
begin rtype := edittype; ed := definecmd end
else if stmnt = cmtype then
begin rtype := filtype; filler := ontype end
end
else if rtype = filtype then
if filler = steptype then
begin rtype := edittype; ed := stepcmd end
else if filler = attype then
begin rtype := edittype; ed := atcmd end
end;
procedure doSetcmd;
var svar: filtypes; b,onoff: boolean; arg: integer;
function getNumericArg(default: integer): boolean;
var b: boolean;
begin
with curToken do
begin
if ttype = constype then b := cons↑.ltype = svaltype
else b := false;
if b then arg := round(cons↑.s) (* use specified argument *)
else if endOfLine then
begin arg := default; b := true end (* use default value *)
else begin pp20L('Need a numeric arg ',18); ppLine; end;
end;
getNumericArg := b;
end;
function getOnOff(default: boolean): boolean;
var b: boolean;
begin
with curToken do
begin
b := (ttype = reswdtype) and (rtype = filtype) and
((filler = ontype) or (filler = offtype));
if b then onoff := filler = ontype
else if endOfLine then
begin onoff := default; b := true end (* use default value *)
else begin pp20L('Expecting ON or OFF ',19); ppLine; end;
end;
getOnOff := b;
end;
begin
getEcmd; (* see what we're setting *)
with curToken do
begin
arg := 1;
if (ttype = reswdtype) and (rtype = filtype) then svar := filler
else if (ttype = reswdtype) and (rtype = stmnttype) and
(stmnt = waittype) then begin svar := nowaittype; arg := -1 end
else svar := defertype; (* no good *)
getEcmd; (* see what we're setting it to *)
case svar of
ppsizetype: begin
b := getNumericArg(3); (* default size is 3 *)
if b then setPPSize(arg); (* set page printer size *)
end;
collecttype: begin (* see if we're collecting stmnts typed to interpreter *)
b := getOnOff(true); (* default is collect *)
if b then collect := onoff; (* set whether to collect *)
end;
lextype: begin
b := getNumericArg(1); (* default is up one level *)
if b then
begin (* *** ??? what do we do ??? *** *) end;
end;
nowaittype: begin (* arg = 1 for nowait, -1 for wait *)
b := getOnOff(true);
if arg < 0 then onoff := not onoff;
if b then
begin
singleThreadMode := onoff;
if (debugLevel < STLevel) or (not tSingleThreadMode) then
setSingleThreadMode(onoff);
end;
end;
others: begin pp20L('Bad SET request ',15); ppLine end;
end;
if ttype = constype then relExpr(cons);
end;
end;
procedure collectStmnt(s: statementp);
var i: integer;
begin
if collect then (* if collecting add it to program *)
with cursorStack[cursor] do
if stmntp and cursorStack[cursor-1].stmntp and
(cursorStack[cursor-1].st↑.stype = blocktype) then
begin
s↑.bpt := false;
s↑.next := st; (* splice in the statement *)
s↑.last := st↑.last;
st↑.last := s;
with s↑.last↑ do
if next = st then next := s else bcode := s;
setCursor := false;
setUp := true; (* need to format new stmnt *)
curLine := 1;
putStmnt(s,ind,99); (* set it up *)
setUp := false;
i := cline;
cline := cline + s↑.nlines; (* update where cursor now is *)
cursorLine := cline;
insertLines(i,s↑.nlines,1); (* make space in display for it *)
firstLine := i;
lastLine := cline - 1;
setCursor := false;
curLine := 0;
putStmnt(dProg,0,99); (* write & display new line(s) *)
adjustDisplay; (* make sure cursor is on screen *)
displayLines(lineNum);
end
else
begin
collect := false;
pp20('Can''t insert here. T',20); pp20('urning collect OFF. ',19);
ppLine;
end;
end;
function atStmnt: boolean;
var b: boolean;
begin
b := cursorStack[cursor].stmntp; (* are we pointing to a statement? *)
if not b then begin pp20L('Must be at statement',20); ppLine end;
atStmnt := b;
end;
procedure doAtCmd;
var np: nodep; b: boolean; s: statementp;
begin
b := false;
with cursorStack[cursor] do (* check pointing at AFFIX statement *)
begin
if stmntp then b := st↑.stype = affixtype;
if b then
begin
np := newNode;
with np↑ do
begin
ntype := exprnode;
op := ttmulop;
arg1 := st↑.frame1;
arg2 := newNode;
arg3 := nil;
end;
with np↑.arg2↑ do
begin
ntype := exprnode;
op := tinvrtop;
arg1 := st↑.frame2;
arg2 := nil;
arg3 := nil;
end;
s := newStatement;
with s↑ do (* make up a new assignment stmnt *)
begin
stype := evaltype;
what := np;
exprs := evalOrder(np,nil,true); (* we want its current value *)
next := s; (* so dFreePdb doesn't flush us *)
last := s;
executeStmnt(s); (* aval will be set by INTERP *)
relNode(np↑.arg2);
relNode(np);
np := aval;
aval↑.t↑.refcnt := 1; (* so it doesn't disappear *)
end;
relStatement(s); (* done with it now *)
with st↑ do
begin
if atexp <> nil then freeNode(atexp); (* release any old AT expr *)
atexp := np;
with frame1↑ do
if ntype = leafnode then np := nil
else np := evalOrder(arg2,nil,true); (* push array subscripts *)
with frame2↑ do
if ntype <> leafnode then np := evalOrder(arg2,np,true);
if byvar <> nil then
with byvar↑ do
if ntype <> leafnode then np := evalOrder(arg2,np,true);
exprs := evalOrder(atexp,np,true);
end;
reFormatStmnt(st,ind,cursorLine); (* may have changed nlines *)
end
else
begin pp20L('Must be pointing at ',20); pp20('an AFFIX statement ',18);
ppLine end;
end;
end;
(* main editing routine: edit *)
begin
makeOuterBlock; (* Make initial BEGIN-END block *)
setCursor := true;
cursorLine := 2;
oc := 1;
lineNum := 1;
oldcline := 1;
oldline := 1;
topDline := 0;
botDline := 0;
displayLines(lineNum); (* show first window *)
done := false;
repeat
showCursor(cursorLine-topDline-firstDline+2,1); (* shift cursor *)
if cursorLine <> oc then
begin
if smartTerminal then
begin
outChar(cursorLine-topDline-firstDline+2,1,'>',false); (* other cursor *)
if (topDline+firstDline-1 <= oc) and
(oc <= topDline+firstDline+dispHeight-2) then
with lines[oc-topDline+1]↑ do (* for bad stmnts redisplay the "!" *)
outChar(oc-topDline-firstDline+2,1,listing[start],false);
end
else
begin
with lines[cursorLine-topDline+1]↑ do (* show ">" cursor *)
begin
ch := listing[start]; (* remember first char of line *)
listing[start] := '>'; (* display cursor *)
out1Line(cursorLine-topDline-firstDline+2,start,length);
listing[start] := ch; (* restore things *)
end;
if (topDline+firstDline-1 <= oc) and
(oc <= topDline+firstDline+dispHeight-2) then
with lines[oc-topDline+1]↑ do (* for bad stmnts redisplay the "!" *)
out1Line(oc-topDline-firstDline+2,start,length);
end
end;
okp := true;
oc := cursorLine; (* remember where we were *)
ol := lineNum;
ch := getCChar;
iCh := ord(ch);
minus := false;
if (version = 10) and ((iCh = (ord('+')+128)) or (iCh = (ord('-')+128))) then
begin (* for SAIL <ctrl>+ or <ctrl>- *)
minus := iCh = (ord('-')+128);
ch := getCChar;
iCh := ord(ch);
end;
if iCh = ctlBslash then (* ↑\ *)
begin (* get repeat count *)
ch := getCChar;
if (ch = '+') or (ch = '-') then
begin
minus := ch = '-';
ch := getCChar;
end;
arg := 0;
while ('0' <= ch) and (ch <= '9') do
begin
arg := 10*arg + (ord(ch) - ord('0')); (* get next digit *)
ch := getCChar;
end;
iCh := ord(ch);
end
else if (version = 10) and
(((ord('0')+128) <= iCh) and (iCh <= (ord('9')+128))) then
begin (* get repeat count -- for SAIL <cntl><digit> *)
arg := 0;
repeat
arg := 10*arg + iCh-260B; (* get next digit *)
ch := getCChar;
iCh := ord(ch);
until ((ord('0')+128) > iCh) or (iCh > (ord('9')+128));
end
else arg := 1;
if minus then arg := -arg;
if (iCh <= ord(' ')) or (ch in ['↑','<','>','[','?','@','!']) then
begin (* Handle single-character commands here.. Mostly editor commands *)
if iCh < ord(' ') then ch := chr(iCh + 64); (* Convert control to normal *)
case ch of
'E': done := true;
'V': begin
redrawDisplay;
oc := 0; (* so we'll redisplay ">" cursor *)
end;
'L': begin
cursorLine := arg; (* new line number *)
setCursor := true;
adjustDisplay; (* make sure it's on screen *)
displayLines(lineNum); (* print out the statement *)
end;
'W',
'U',
'T',
'B': begin
if (ch = 'T') or (ch = 'U') then arg := - arg; (* rolling down *)
if (ch <= 'T') then lineNum := lineNum + 4 * arg (* glitches *)
else
begin
lineNum := lineNum + (dispHeight-1) * arg; (* screenfuls *)
if ch = 'W' then cursorLine := lineNum (* move cursor too *)
else cursorLine := lineNum + dispHeight - 1;
setCursor := true;
end;
displayLines(lineNum);
end;
'↑',
'S',
'N',
'<',
'>',
'H',
'M': begin (* backspace & return *)
if (ch = 'H') or (ch = '<') then arg := - arg; (* rolling down *)
if (ch = '<') or (ch = '>') then cursorLine := cursorLine + 4 * arg
else if ch = '↑' then parentStmnt(abs(arg)) (* up n levels *)
else if (ch = 'S') or (ch = 'N') then
if minus then lastStmnt(-arg,ch='S') (* up n stmnts *)
else nextStmnt(arg,ch='S') (* down n stmnts *)
else cursorLine := cursorLine + arg;
if cursorLine < 1 then cursorLine := 1
else if cursorLine > dprog↑.nlines then cursorLine := dprog↑.nlines;
adjustDisplay; (* make sure cursor is on screen *)
setCursor := true;
displayLines(lineNum);
end;
'P': begin
if minus then (* put cursorLine at bottom of screen *)
lineNum := cursorLine - dispheight + 1
else lineNum := cursorLine; (* put cursorLine at top of screen *)
displayLines(lineNum); (* shift the display *)
end;
'O': begin
cursorLine := oldcline; (* jump back to where we were *)
if (cursorLine < lineNum) or
(lineNum + dispHeight - 1 < cursorLine) then
lineNum := oldline;
setCursor := true;
displayLines(lineNum);
end;
'G': begin
i := cursorLine;
gotoMark(arg); (* for now can only go to marks *)
if i <> cursorLine then
begin
setCursor := true;
adjustDisplay;
displayLines(lineNum); (* print out the statement *)
end;
end;
'D': begin
if (arg = 1) and (fieldNum = 0) and cursorStack[cursor].stmntp then
begin (* just flush statement label *)
curChar := 1;
maxChar := 0;
labelParse;
end
else delStmnt(arg);
lineNum := topDline + firstDline - 1;
oc := 0; (* so we'll redisplay ">" cursor *)
end;
'Y': begin (* for now dump cursorStack *)
if ppBufp > 0 then ppLine;
for i := 1 to cursor do
with cursorStack[i] do
begin
ppInt(i); pp10(' - line: ',9); ppInt(cline);
if stmntp then
begin pp10(' stmnt: ',8); ppInt(ord(st↑.stype));
ppChar(' '); ppInt(st↑.nlines) end
else begin pp10(' node: ',7); ppInt(ord(nd↑.ntype)) end;
if i = cursor then begin ppchar(' '); ppInt(fieldNum) end;
ppLine;
end;
end;
'A',
'C': begin
pp20L(' Can''t attach/copy c',20); pp10('ode yet ',7);
ppLine;
okp := false;
end;
'F': begin
pp20L(' Find won''t work for',20); pp20(' a long while yet ',17);
ppLine;
okp := false;
end;
'I',
' ': begin
with lines[oc-topDline+1]↑ do (* for bad stmnts redisplay the "!" *)
if smartTerminal then
outChar(oc-topDline-firstDline+2,1,listing[start],false)
else
out1Line(oc-topDline-firstDline+2,start,length);
b := (ch = ' ');
if b then
with cursorStack[cursor] do
if stmntp then b := st↑.stype <> emptytype;
if b then editStmnt
else
begin
with cursorStack[cursor] do
if stmntp then
if (st↑.stype <> emptytype) and (st↑.stype <> endtype) and
(st↑.stype <> coendtype) then
begin
b := cline <> cursorLine; (* 2nd line of AFFIX, ELSE, after label *)
if not b then
with cursorStack[cursor-1] do
if stmntp then b := st↑.stype <> blocktype
else b := nd↑.ntype = procdefnode;
end;
if not b then addStmnt(true)
else begin pp20L(' Can''t insert here ',18); ppLine end;
end;
oc := 0; (* so we'll redisplay ">" cursor *)
end;
'[': begin
bracketStmnt;
end;
'?': begin
pp20L('Don''t panic. ',12); ppLine;
okp := false;
end;
'@': begin (* Move cursor to current pc *)
cursorLine := pcLine;
setCursor := true;
adjustDisplay;
displayLines(lineNum); (* shift display if necessary *)
end;
'!': begin (* abbreviated debugger commands *)
ch := getAChar;
iCh := ord(ch);
ch := upperCase(ch); (* To upper case *)
ppChar(ch); ppLine; (* echo it *)
case ch of
'B': begin
if arg = 0 then clrAllBpts
else if atStmnt then
with cursorStack[cursor] do
if arg > 0 then setBpt(st) else clrBpt(st);
end;
'A': begin
stepStmnt(2);
runStmnt;
end;
'S': begin
stepStmnt(1);
runStmnt;
end;
'N': begin
stepStmnt(3);
runStmnt;
end;
'G': begin
stepStmnt(4);
runStmnt;
end;
'T': begin
if atStmnt then (* ok to set breakpoint? *)
begin
setTBpt(cursorStack[cursor].st); (* put a temporary breakpoint there *)
runStmnt; (* & proceed with program *)
end
end;
'P': runStmnt; (* Proceed with program *)
'R': begin (* Run/Restart program *)
saveOutermostEnv; (* reset Interpreter *)
runStmnt; (* Start program from the top *)
end;
'X': begin (* Execute statement at current cursor location *)
if atStmnt then executeStmnt(cursorStack[cursor].st);
end;
others: begin
pp5(' huh?',5); ppOutNow;
okp := false;
end;
end;
end;
others: begin (* ??? *)
pp20L(' unknown command ',17); ppLine;
okp := false;
end;
end
end
else (* Not a single-char command. Probably a letter *)
begin
ppDelChar; (* Delete character and retype on next line *)
ppLine;
listing[1] := ch;
readPPline(1);
getEcmd; (* see what we're being asked to do *)
with curToken do
if (ttype = reswdtype) and (rtype <> optype) then
if rtype = edittype then (* editor/debugger command *)
case ed of
savecmd: writeProg; (* Write out program to file *)
getcmd: begin
readProg; (* Read in new program from file *)
oc := 0;
end;
definecmd: varDefine; (* write Definitions for the specified vars *)
(* insertcmd,renamecmd.... *)
setcmd: doSetcmd; (* change appropriate system var *)
markcmd: mark;
unmarkcmd: begin
getEcmd;
if (ttype = reswdtype) and (rtype = filtype) and
(filler = alltype) then unmark(true) else unmark(false);
end;
(* debugger commands follow *)
popcmd: begin
if debugLevel = 0 then
begin
(* *** probably should ask if luser wants to zero or save *** *)
(* *** the variables in outermost environment. *** *)
(* *** if zeroing then *** *)
(* *** begin flushOldEnvironments(0); initOuterBlock end *** *)
(* *** else *** *)
saveOutermostEnv;
end
else flushOldEnvironments(debugLevel); (* pop up a level *)
setECurInt;
end;
tracecmd: begin
getEcmd;
if (ttype = reswdtype) and (rtype = filtype) and
(filler = alltype) then trace(true) else trace(false);
end;
breakcmd: begin
if atStmnt then setBpt(cursorStack[cursor].st); (* ok to set it *)
end;
unbreakcmd: begin
getEcmd;
if (ttype = reswdtype) and (rtype = filtype) and
(filler = alltype) then clrAllBpts
else
if atStmnt then clrBpt(cursorStack[cursor].st); (* ok to clear it *)
end;
tbreakcmd: begin
if atStmnt then (* ok to set breakpoint? *)
begin
setTBpt(cursorStack[cursor].st); (* put a temporary one there *)
runStmnt; (* & proceed with program *)
end
end;
stepcmd: begin
stepStmnt(1);
runStmnt;
end;
sstepcmd: begin
stepStmnt(2);
runStmnt;
end;
nstepcmd: begin
stepStmnt(3);
runStmnt;
end;
gstepcmd: begin
stepStmnt(4);
runStmnt;
end;
proceedcmd: runStmnt; (* Proceed with program *)
gocmd: begin (* Jump to current cursor location *)
if atStmnt then goStmnt;
end;
executecmd: begin (* Execute statement at current cursor location *)
if atStmnt then executeStmnt(cursorStack[cursor].st);
end;
startcmd: begin
saveOutermostEnv; (* reset Interpreter *)
runStmnt; (* Start program from the top *)
end;
atcmd: doAtCmd;
calibratecmd:
calibrate;
others: begin (* ??? *)
pp20L(' unknown command ',17); ppLine;
okp := false;
end;
end
else (* Not an editor command but still a reserved word *)
begin
backup := true;
if declarationp then (* Is it a declaration? Add it if so *)
begin
backup := true;
addStmnt(false);
end
else (* Probably some stmnt [if, for, etc] *)
begin (* have parser parse it *)
sParse := true;
fParse := true;
backup := true;
s := newStatement;
s↑.stype := emptytype;
curLine := 0;
pushStmnt(s,0); (* so addStmnt will work right *)
sCursor := cursor;
i := cursorLine;
cursorLine := 1;
newDeclarations := nil;
addStmnt(false);
cursor := sCursor - 1; (* restore cursor *)
cursorLine := i;
sParse := false;
fParse := false;
i := addNewDeclarations;
if s↑.stype = emptytype then relStatement(s)
else
begin
collectStmnt(s); (* if collecting add stmnt to prog *)
executeStmnt(s); (* go do it *)
end;
end
end
else (* Not a reserved word, or some operator *)
begin (* Probably an assignment stmnt, or an expr to evaluate *)
backup := true;
n := exprParse; (* see what we're to evaluate *)
getToken; (* & check if it's followed by an ":=" *)
if (ttype = reswdtype) and (rtype = stmnttype) and
(stmnt = assigntype) then (* Is it an assignment? *)
begin (* Yes - need to parse it *)
s := newStatement;
s↑.stype := assigntype;
sParse := true;
fParse := true;
backup := true;
assignParse(s,n);
sParse := false;
fParse := false;
i := addNewDeclarations;
collectStmnt(s); (* if collecting add stmnt to prog *)
executeStmnt(s); (* go do it *)
end
else pevalExpr(n); (* eval & print out expr *)
end
end;
if (oc <> 0) and (abs(cursorLine-oc) > 4) then
begin
oldcline := oc; (* remember for "O" command *)
oldline := ol;
end;
if okp then
begin
pp5(' ok ',4);
ppOutNow;
end;
if PPbufp > 60 then ppLine;
until done;
echo(true); (* turn echoing back on *)
resetScreen; (* restore world for main *)
writeln(ttyoutput);
end;
begin
end.